------------------------->  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>  <--------------

-- Notes on getting the full thing working with changed pointer values.
-- Start out by creating the objects.
-- Create a "proper" value of each object in turn by creating a new
-- object and inserting all the elements of the existing object
-- It then copies the attributes of this newly created object
-- back into the existing object.
-- This has been implemented, but it is up to the user to mark
-- classes that need to be rehashed by putting them under
-- $SUPPORTS_REHASH.  Classes that cannot be rehashed may need
-- an additional supertype
-- 
-- This does not work if the object has a variable array portion that
-- is *different* for the rehashed object.  There is then no way to
-- copy objects back into their original location.  This could be
-- accomplished if rehashing could always *increase* the allocated
-- space. Then, after some number of passes through the system, it
-- would settle into a good solution

class STORE is
   -- Used to store objects in an ascii readable way.
   -- Requires the -reflect compiler option
   -- 
   -- Usage:
   --     ob1,ob2: FOO ....
   --     f: FILE := FILE::open_for_write("myfile");
   --     store ::= #STORE(f);
   --     store+ob1;
   --     store+ob2;
   -- Or
   --     s: STR_STREAM := #;
   --     store2 ::= #STORE(s);
   --     store2+ob1;
   --     store2+ob2;
   --     #OUT+s.str; -- holds the string representation of ob1 and ob2
   -- 
   -- Objects are written out in the following form
   --      Each reference object has an integer index - starting at 0 and
   --      increasing.
   --      Object -> Reference | SeenBefore | Array
   --      Reference -> #<typename>( Objectfields)
   --      Objectfields -> <name = Object><,<name=Object>>*
   --      Array -> #[num array elts]<typename>(Object Fields)[ Arrayfields]
   --      Arrayfields -> <Object><,Object>*
   --      SeenBefore -> [object_index]
   --      Special kinds of objects:
   --      INT -> <digits>
   --      FLT -> <digits>.<digits>
   --      FLTD -> <digits>.<digits>d
   --      BOOL -> true|false
   --      STR -> "  "
   --      CHAR -> '
   --      void -> v
      
   private const debug: BOOL := false;
   private attr already_stored: MAP{$OB,$OB}; -- Mapping from objects
   -- that have already been stored to indices
   private attr cur_index: INT; -- Indicates the index of the next
   -- integer to be used as an id for a reference object. Problems
   -- could arise if too many reference objects are being stored
   -- causing the counter to cycle.
   -- Always access via "next_index", not directly
   private attr cur_indent: INT;
   
   readonly attr output: $OSTREAM; -- Stream onto which data is written

   create(o: $OSTREAM): SAME is
      -- Create a new store using the output stream "o"
      res ::= new;
      res.output := o;
      res.already_stored := #;
      res.cur_index := -1;
      res.cur_indent := 0;
      return res;
   end;
   
   plus(ob: $OB): SAME pre check_output is
      -- Append another object to the output stream self must exist.
      -- 
      -- Limitations. Cannot store a "top level" void value.
      -- Particularly bad for immutable objects. Best to box up any
      -- immutable objects into some other top-level object for
      -- storage.  Note that there is no problem with void values
      -- *within* the object.
      pack_object(ob);
      return self;
   end;
   
   plus(ob: $OB) pre check_output is discard ::= plus(ob) end;
      -- Append another object to the output stream
   
   private pack_object(ob: $OB) is
      -- Pack starting at a particular indent level
      -- Attributes are copied starting at this level
      if void(ob) then
	 -- If a void reference or value type, 
	 -- If it is a value class, we need to determine what the type
	 -- is. If it is a reference class, we can just store a void pointer.
	 app(" v "); 
	 return;
      end;
      tp ::= SYS::tp(ob);
      assert tp/= 0; -- Implementation detail. No type should be equal to zero
      tp_str ::= SYS::str_for_tp(tp);
      if tp < 0 then
	 -- Special things to do for basic value types
	 typecase ob
	 when INT then   app(ob.str); return;
	 when BOOL then  app(ob.str); return;
	 when CHAR then  app("\'"+ob.str+"\'"); return;
	 when FLT then   fltstr: STR := ob.str;
	    if ~fltstr.contains('.') then fltstr := fltstr+".0"; end;
	    app(fltstr); 
	    return;
	 when FLTD then  
	    -- Not sure that this works properly - must check FLTD::str
	    -- to see if stuff like 128192891e34 are possible, in which
	    -- case the following will be wrong
	    fltstr: STR := ob.str;
	    if ~fltstr.contains('.') then fltstr := fltstr+".0"; end;
	    app(fltstr+'d'); 
	    return;
	 else -- continue
	 end;
      end;
      typecase ob   
      when STR then   app("\""+ob+"\""); return; 
      else			-- Continue;
      end;
	 
      -- Don't register immutable objects...
      if SYS::tp(ob) > 0 then	-- if is_reference then
	 var_name: INT;
	 if get_id(ob, out var_name) then
	    -- Check to see whether the object was packed earlier. Just
	    -- use reference
	    app("[ "+var_name+ " ]");
	    return;
	 end;
      end;

      n_attribs: INT := REFLECT::n_attribs(ob);
      arr_size: INT := REFLECT::array_size(ob);
      
      output+("#");
      if arr_size >= 0 then output+("[ "+arr_size+" ]");  end;
      output+(tp_str+"(");
      -- Pack the attributes
      loop i ::= n_attribs.times!;
	 if i /= 0 then app_nonl(","); end;
	 nm ::= REFLECT::attrib_name(ob,i);
	 val ::= REFLECT::attrib(ob,i);
	 app_nonl(nm+" = ");
	 upindent;
	 pack_object(val);
	 downindent;
      end;
      app(")");
      do_newline;
      if arr_size > 0 then -- it's negative 1  if there's  no array part
	 app("[");
	 loop aind ::= arr_size.times!;-- Index of array element
	    if aind /= 0 then app_nonl(","); end;
	    aelt ::= REFLECT::array_element(ob,aind);
	    upindent;
	    pack_object(aelt);
	    downindent;
	 end;
	 app(" ]")
      end;
   end;

   private get_id(ob: $OB, out id: INT): BOOL is
      -- Return an identifier "id" for the object "ob"
      -- Returns true if the object has already been packed
      -- Otherwise return false
      assert ~void(ob);
      if already_stored.has_ind(ob) then
	 id := CAST{INT}::from(already_stored[ob]);
	 assert deb("Previously packed. Returning id:"+id);
	 return true;
      else
	 id := next_index;
	 assert deb("New object. Assigning id:"+id);
	 already_stored[ob] := id;
	 return false;
      end;
   end;
   
   private next_index: INT is
      -- Return the next unique integer for this packing context
      cur_index := cur_index + 1;
      assert cur_index < INT::maxint; -- If this happens, we have wrap around
      return cur_index;
   end;
   
   private upindent is cur_indent := cur_indent+1; end;
   private downindent is 
      if cur_indent > 0 then cur_indent := cur_indent - 1 end;
   end;
   
   private do_newline is 
      output+"\n";
      loop cur_indent.times!; output+"   "; end;
   end;
   
   private app(s: STR) is   output + s;      do_newline;  end;
   
   private app_nonl(s: STR) is  output + s ;  end;
   
   private deb(msg: STR): BOOL is
      if debug then #ERR+msg; end;
      return true;
   end;
   
   check_output: BOOL  is
      if void(output) then  raise STORE_EXC::no_output;
      else return true; end;
   end;
      
end;
------------------------------------------------------------------------
class RESTORE{T} is
   -- Recreate objects of type T from a string. A wrapper around RESTORE
   -- that expects to read objects of type "T"
   -- 
   --   myfoo: FOO := ....
   --   f: FILE := FILE::open_for_write("foo");
   --   store: STORE := #(f);
   --   store+myfoo;  -- Store some arbitrary object onto the file "f"
   -- 
   --   f: FILE := FILE::open_for_read("foo");
   --   file_str:STR := f.get_str
   --   r: RESTORE{FOO} := #(file_str);
   --   foo: FOO;
   --   if r.next_object(out foo) then .. use foo
   --   else #ERR+"Bad object read from the string" end;

   readonly attr r: RESTORE;
   
   create(st: STR): SAME is 
      res ::= new;
      res.r := #RESTORE(st);
   end;
   
   next_object(out res:T): BOOL pre ~void(r) is
      -- Return true if an object of type T was read.
      -- Else return false
      o: $OB;
      if r.next_object(out o) then
	 typecase o
	 when T then res := o; return true;
	 else res := void; return false; end;
      else 
	 res := void;
	 return false;
      end;
   end;
   
   check_restore: BOOL is
      if void(self) or void(r) then return false
      else return r.check_restore end;
   end;
   
end;
------------------------------------------------------------------------
class RESTORE is
   -- Restore an object from a string. 
   -- Usage: 
   --   myfoo: FOO := ....
   --   f: FILE := FILE::open_for_write("foo");
   --   store: STORE := #(f);
   --   store+myfoo;  -- Store some arbitrary object onto the file "f"
   -- 
   --   f: FILE := FILE::open_for_read("foo");
   --   file_str:STR := f.get_str
   --   r: RESTORE := #(file_str);
   --   ob: $OB;
   --   if r.next_object(out ob) then ... use ob 
   --   else #ERR+"Bad object read" end;
   --   

   const debug: BOOL := false;
   private attr registry: MAP{$OB,$OB}; -- Mapping from ids to objects
   -- that have been read in
   private attr cur_object_index: INT; -- Index of the most recent object
   -- read or being read
   
   private attr sc: STR_CURSOR; -- String cursor on the current source
   
   create(st: STR): SAME is
      -- Create a new unpacking context
      res ::= new;
      res.registry := #;
      res.sc := st.cursor;
      res.cur_object_index := -1;
      return res;
   end;
   
   next_object(out ob: $OB): BOOL is
      -- Return true if the next object was found
      -- Store the next object in "ob" if one was found
      sc.skip_space;
      if sc.is_done then return false end;
      ob := parse_object;
      typecase ob
      when $SUPPORTS_REHASH then ob.rehash; 
      else			-- Do nothing
      end;
      return true;
   end;

   private next_int: INT is
      -- Generator of integers to indicate successive objects. Back references
      -- are done by indicating the integer index of the object
      -- This must essentially replicate the behavior on the  "STORE" end
      cur_object_index := cur_object_index + 1;
      return cur_object_index;
   end;
   
   private parse_object: $OB pre check_restore is
      -- Restore from the string "st"
      -- start_index indicates where in the string to start reading from and
      -- fin_index is set to the last character consumed.
      res: $OB; 
      sc.skip_space;
      next_char: CHAR := sc.item;
      assert deb("Reading next object. First char="+sc.item+"\n");
      if parse_basic(out res) then return res;   end;
      assert deb("Non basic type:"+next_char+" ");
      case next_char
      when '#' then 
	 assert deb("Array or object\n");
	 -- First get the class name, number of fields array size etc.
	 discard ::= get_char("");
	 arr_size: INT := -1;	-- Indicates no array
	 case sc.item
	 when '[' then  
	    discard := get_char("Eating [ of array size");
	    arr_size := sc.get_int;
	    check_sc("Array size");
	    sc.skip_space;
	    assert deb("Array of size:"+arr_size+"\n");
	    discard := get_char("Eating ] of array size");
	 else			-- No array part
	 end;
	 class_name: STR := sc.get_str_upto('(');
	 class_type_tag: INT := REFLECT::tp_for_str(class_name);
	 if class_type_tag = 0 then
	    raise err("Class:"+class_name+" does not exist.\n "
		      "To fix this problem you might need to make sure that\n"
		      " at least one instance of this class is reachable "
		      "in your current program ");
	 end;
	 id: INT := next_int;
	 assert deb("\nAssigning Identifier:"+id+" class_name:"+class_name+"\n");
	 -- All the information exists (n fields, array size).Create the object
	 if arr_size >= 0 then
	    res := REFLECT::create_object(class_type_tag,arr_size);
	 else
	    res := REFLECT::create_object(class_type_tag);
	 end;
	 register_ob(id,res); 
	 -- Object has been created. Now read the fields
	 sc.skip_space;
	 get_and_check_char('(',"Expecting ( of object");
	 no_more_fields: BOOL := false;
	 loop until!(no_more_fields);
	    field_name: STR := get_word("field name");
	    sc.skip_space;
	    get_and_check_char('=',"Equal sign in field assignment");
	    object: $OB := parse_object;
	    set_attrib_named(res,field_name,object);
	    sc.skip_space;
	    if sc.item = ')' then 
	       get_and_check_char(')',"Done with object fields");
	       no_more_fields := true;
	    else get_and_check_char(',',"Next field"); end;
	 end;
	 if arr_size >= 0 then
	    sc.skip_space;
	    get_and_check_char('[',"Expected [. Reading array portion");
	    loop aind: INT := arr_size.times!;
	       assert deb("Parsing array index:"+aind+"\n");
	       array_elt: $OB := parse_object;
	       REFLECT::set_array_element(res,aind,array_elt);
	       sc.skip_space;
	       if aind /= (arr_size-1) then 
		  get_and_check_char(',',"Next array element"); 
	       end;
	    end;
	    sc.skip_space;
	    get_and_check_char(']',"Expected ] Reading array portion");
	 end;
      when '[' then
	 -- Reference to a previous object. Just find previous definition
	 assert deb("\nReference to previous object\n");
	 get_and_check_char('[',"");
	 id: INT := get_int("Identifier");
	 assert deb("Object index:"+id);
	 get_and_check_char(']',"Expecting close paren");
	 res := get_registered_ob(id);
      when 'v' then
	 -- Void object.
	 get_and_check_char('v',"");
	 assert deb("\nVoid object\n");
	 return void;
      else
	 raise err("Unexpected char:"+next_char);
      end;
      return res;
   end;

   private get_and_check_char(c: CHAR,msg:STR) is
      sc.skip_space;
      ch ::= sc.get_char;
      if ch /= c then
	 raise err("Unexpected character:"+ch
		   +" Expecting char:"+c+"\n\t"+msg+"\n");
      end;
   end;

   private parse_basic(out res:$OB): BOOL is
      next_char: CHAR := sc.item;
      case next_char
      when '\'' then
	 discard ::= get_char("Reading CHAR open quote");
	 char_val: CHAR := get_char("Reading CHAR");
	 get_and_check_char('\'',"Reading CHAR close quote");
	 res := char_val;
	 return true;
      when '\"' then 
	 -- String. Get upto closing quote
	       str: STR := "";  -- Funny emacs indent...
	 discard ::= get_char("Reading STR open quote");
	 ch ::= get_char("Reading string");
	 loop until!(ch='\"');
	    str := str+ch;
	    ch := get_char("Reading string");
	 end;
	 res := str;
	 return true;
      when '0','1','2','3','4','5','6','7','8','9' then
	 s: STR :=get_word("Reading INT, FLT or FLTD");
	 sc2: STR_CURSOR := s.cursor;
	 if s.contains('.') then  -- Either FLT or FLTD
	    if s[s.size - 1] = 'd' then  res := sc2.get_fltd; 
	    else res := sc2.get_flt; end;
	 else			-- INT
	    res := sc2.int
	 end;
	 if sc2.has_error then raise err("Bad INT, FLT or FLTD:"+s); end;
	 return true;
      when  't' then
	 val: STR := get_word("Reading BOOL(true)");
	 if val = "true" then   res := true;   return true;
	 else raise err("Bad BOOL. True expected"+val); end;
      when 'f' then
	 val: STR := get_word("Reading BOOL (false)");
	 if val = "false" then   res := false;   return true;
	 else raise err("Bad BOOL. False expected"+val); end;
      else
	 return false
      end;   
   end;
   
   private get_char(msg: STR): CHAR  is
      res ::= sc.get_char;
      if sc.has_error then
	 raise err("Error getting the next character:"+msg);
      end;
      -- assert deb("["+res+"]");
      return res;
   end;

   private get_int(msg: STR): INT is
      i: INT := sc.get_int;
      if sc.has_error then raise err("Bad INT:"+msg); end;
      return i;
   end;
   
   private get_word(msg: STR): STR is
      sc.skip_space;
      res ::= sc.get_word;
      if sc.has_error then raise err("Bad word:"+msg); end;
      return res;
   end;
   
   private get_registered_ob(id: INT): $OB is
      if ~registry.has_ind(id) then
	 #ERR+"Registry has objects upto index:"+registry.size+"\n";
	 raise err("No object registered with id:"+id);
     else return registry[id] end;
   end;

   private register_ob(id: INT, ob: $OB) is
      -- If ob is not immutable, register it
      if SYS::tp(ob) > 0 then registry[id] := ob; end;
   end;

   private check_sc(msg: STR) is
      -- Raise an error if the string cursor has an error
      if sc.has_error then raise err(msg) end; 
   end;
   
   private set_attrib_named(ob:$OB,field:STR,to:$OB) 
   -- Set the field named "field" in the object "meta" to the value "ob"
   -- Error if no such field exists in the current object
   is
      n_attribs: INT := REFLECT::n_attribs(ob);
      loop attrib_ind: INT := n_attribs.times!;
	 if REFLECT::attrib_name(ob,attrib_ind) = field then
	    REFLECT::set_attrib(ob,attrib_ind,to);
	    return;
	 end;
      end;
      raise err("No such field:"+field);
   end;

   private deb(msg: STR): BOOL is
      if debug then 
	 #ERR+'\n'+sc.current_line_str+'\n';
	 #ERR+sc.current_loc_str('^')+'\n';
	 #ERR+msg; 
      end;
      return true;
   end;
   
   private err(msg: STR): STORE_EXC is
      info ::= "Line:"+sc.line_no+"\n";
      info := info+sc.current_line_str;
      info := info+"\n"+sc.current_loc_str('^');
      return STORE_EXC::parse_err(msg+" \nAt location:\n"+info);
   end;
   
   check_restore: BOOL  is
      if void(self) then  raise STORE_EXC::no_restore_context;
      else return true; end;
   end;
   
end;
------------------------------------------------------------------------
class STORE_EXC < $STR is
   -- Packing exceptions 
   
   const no_output_str: STR := "Cannot use a store without an output string";
   const no_restore_context_str: STR := 
	 "RESTORE is void. Cannot restore a string without a context";
   const past_end_of_str: STR := "RESTORE went past end of string...";
   const parse_err_str: STR := "RESTORE encountered a parsing error.";
   
   readonly attr str: STR;
   
   readonly attr msg: STR; -- Additional message
   
   private create(s: STR,msg: STR): SAME is
      -- Create a new store exception
      res ::= new;
      res.str := s;
      res.msg := msg;
      -- Print out the error message anyhow - in case it is not caught
      #ERR+"\n*********************************************\n";
      #ERR+ "A packing error occurred\n"+s+"\n"+"Message:"+msg+"\n";
      return res;
   end;
   
   no_output: SAME is  return create(no_output_str,""); end;
   no_restore_context: SAME is  return create(no_restore_context_str,""); end;
   past_end_of_str(msg:STR): SAME is return create(past_end_of_str,msg); end;
   parse_err(msg:STR): SAME is return create(parse_err_str,msg); end;
   
end;
------------------------------------------------------------------------
