store.sa
Generated by gen_html_sa_files from ICSI. Contact gomes@icsi.berkeley.edu for details
---------------------------> Sather 1.1 source file <--------------------------
--
-- 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
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: H_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}
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
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: H_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
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;