[Date Prev] [Date Next] [Thread Prev] [Thread Next] Date Index Thread Index Search archive:
Date:Mon Nov 4 13:39:51 1996 
Subject:news-relayFrom: pop@roo.cs.umass.edu (Robin Popplestone) 
From:PP User 
Volume-ID:961104.03 

-----------------------------------------------------------------------------
/*
save_data.p                         Robin Popplestone MAR 1994

This file may be freely copied and modified provide the above attribution
is preserved or extended as appropriate.

         CONTENTS - (Use <ENTER> g to access required sections)

 --  before_obj(x,y) compares the index of two structures to support sorting.
 --  index(Struct) is the index number of an structure in the save-file.
 --  assign_index forces an structure and its sub-structures to have indices.
 --  save_field(Struct) writes out a record or vector component.
 --  save_struct(Struct) writes the index, components of the structure
 --  save_data(Struct,FileSpec) is the main procedure which writes Struct.
 --  Errata and inefficiencies.

*/

section SAVE_DATA => save_data;

vars procedure(
    before = nonop <=,
    class_save = newassoc([]),
    index,
    pr_header, pr_trailer,
    P_index,
    P_prop);

vars i_last = 0;
vars i_written = 0;
vars List_Deferred = [];
vars Struct_now = undef;


/*
before_obj(x,y) compares the index of two structures to support sorting.
-----------------------------------------------------------------
*/
define lconstant before_obj(x,y);
  before(P_index(x), P_index(y));
enddefine;

;;; trace SAVE_DATA$-before;


/*
index(Struct) is the index of an structure in the save-file.
------------------------------------------------------------
If Struct does not occur in P_index, then (1) we assign the next free
index number to it, and record it in the List_Deferred for future output.

At the same time we assign an index to the data-key of the structure if
it is a user-defined key.
*/


define new_index(Struct); lvars Struct;
   i_last + 1 ->> i_last;
enddefine;

/*
assign_index forces an structure and its sub-structures to have indices.
------------------------------------------------------------------------
*/

define lconstant assign_index(Struct);      lvars Struct;
    if P_index(Struct) then return
    endif;
    if iscompound(Struct) then
        if isproperty(Struct) then                                 ;;; P1
            assign_index(property_default(Struct));
        elseif isarray(Struct) then                                ;;; A1
            assign_index(arrayvector(Struct));
        endif;

        if     Struct == false or Struct == true
        or Struct == termin or Struct == []
        or (isprocedure(Struct) and not(isclosure(Struct))
            and not(isproperty(Struct)) and not(isarray(Struct)))

        or isword(Struct) or isstring(Struct) then
        else
             index(Struct)->;
             appdata(Struct,assign_index);
        endif
 ;;;   else spr(Struct)
    endif;
enddefine;

define  index(Struct) -> i;
        lvars i = P_index(Struct);
        if i then return;
        endif;
    new_index(Struct) ->> P_index(Struct) -> i;   /* 1 */
        Struct::List_Deferred -> List_Deferred;
enddefine;

/*
define  index(Struct) -> i;
    lvars i = P_index(Struct);
    if i then return;
    endif;
    if iskey(Struct) and not(isinheap(Struct)) then return
    endif;
    lvars k = datakey(Struct);
    if isinheap(k) then
    ;;;    assign_index(class_field_spec(k));
        index(k) -> ;
    endif;
    Struct::List_Deferred -> List_Deferred;
enddefine;
*/

define  pr_string(S);
  lvars i,S;
  cucharout(`'`);
  for i from 1 to datalength(S) do
     lvars c = subscrs(i,S);
     if c = `'` or c = `\\` then cucharout(`\\`);
     endif; cucharout(c);
  endfor; cucharout(`'`);
enddefine;


/*
save_field(Struct) writes out a record or vector component.
----------------------------------------------------------
If Struct is a simple item or is  a certain kind of compound item (1-7) it  is
written out either "as itself" (e.g. as a  string) or as the name of a  global
variable or constant whose value is expected to be itself (e.g. false). At (5)
we check that  a procedure  can (one hopes)  be reconstituted  from its  name.
Otherwise (8) we write out the index for the structure in parentheses.

Properties require  special treatment  (P1).  Because it  is not  possible  to
update all the components of a property, e.g. the default-value, we have to be
sure to assign index  numbers for the components  of the property -before-  we
assign that of the property, so that the restore_data procedure does not  have
to update a  forward reference  to the  components. [??  Note if  we did  this
systematically, we could reduce forward  references in the restore_data  proc.
with some gain in efficiency.]

This procedure is -not- lconstant.
*/

define  save_field(Struct);      lvars Struct;
    if iscompound(Struct) then
        if isproperty(Struct) then                                 ;;; P1
            assign_index(property_default(Struct));
            lvars AList = datalist(Struct);
            AList -> P_prop(Struct);
             assign_index(AList);
        elseif isarray(Struct) then                                ;;; A1
            index(arrayvector(Struct)) -> ;
        endif;

        if     Struct == false then spr("false");                  ;;; (1)
        elseif Struct == true then spr("true");                    ;;; (2)
        elseif Struct == termin then spr("termin");                ;;; (3)
        elseif Struct == [] then  spr("nil");                      ;;; (4)
        elseif isprocedure(Struct) and not(isclosure(Struct))         ;;; (5)
            and not(isproperty(Struct)) and not(isarray(Struct))
            then
            lvars Name = pdprops(Struct);
            if isword(Name) and  valof(Name) = Struct then spr(Name);
            else mishap('save_data needs procedure with name=valof',
                    [^Struct pdprops ^Name saving ^Struct_now]);
            endif;
        elseif isword(Struct) then pr('"\''); pr(Struct); pr('\'"');  ;;; (6)
        elseif isstring(Struct) then                               ;;; (7)
            dlocal pop_pr_quotes = true;
            pr_string(Struct);

;;;     elseif iscomplex(Struct) then
;;;         lvars (r,i) = destcomplex(Struct);

        elseif isddecimal(Struct) then
             if Struct = 0 then
                spr(Struct);
             else
                 lvars n_before = max(1,intof(abs(log10(Struct)) + 1));
                 lvars n_after  = max(1,20 - n_before);
                 prnum(Struct,n_before,n_after);
                 pr(' ');
             endif;
        else                                                    ;;; (8)
            pr('('); pr(index(Struct)); pr(')');
        endif
    else spr(Struct)
    endif;
enddefine;

;;; trace save_field index new_index;

/*
save_struct(Struct) writes the index, components of the structure
-----------------------------------------------------------------
We store Struct to Struct_now in (0) to support better error reporting.
At (1) we check to see if the structure has already been
written (?? can this occur...), and return if it has.
we make sure that the structure has components in a meaningful
sense, which it should do. Given that it does, at (2) we see if there
is a user defined -class_save- procedure, and call it if there is.
Otherwise (3) we make sure that we don't have a "simple" compound structure
like -true- which should have been written out by -save_field- and so
should not have been given to -save_struct-.
So, at (4) we actually have an structure with components.
We treat the special cases of properties (P), closures (C) and
arrays (A). In each case we generate output as specified in HELP * SAVE_DATA.

At (P) we are writing a property. The global -P_prop- will contain the index
of the data-list of the property. This must not be a forward reference,
so save_field will have made sure it is not by writing it when the first
the property is encountered. Likewise save_field has made sure that the
default value does not contain a forward reference.

At (A) we are writing an array. We can output the boundslist (A1) by spr
because it must be all integers, thus avoiding an inadmissable
forward reference. We save the -pdprops- of the array. We do NOT save
the updater because the updater of an array can't be changed anyway.

Writing out closures (C) is straightforward - we save the pdpart and
updater. The frozvals are saved as part of the default operation of
save_struct.

Finally, in the general case (G), we write the dataword followed by
all the components, written out with save_field.

We should never arrive at (6), since non-compound structures will be output
directly.

*/

lconstant Msg_ss = 'Error in save_data-this should not happen';

define  save_struct(Struct);
    lvars Struct;
    Struct -> Struct_now;                                   ;;; (0)
    if iscompound(Struct) then                              ;;; (1)
        lvars i = index(Struct);
        if before(i,i_written)  then return;
        endif;
        pr('\n');
        spr(i);
        lvars P_save = class_save(datakey(Struct));         ;;; (2)
        if P_save then
            spr(dataword(Struct)); P_save(Struct); pr(";");
            return;
        elseif  Struct == false or Struct == true           ;;; (3)
        or Struct == termin or Struct == []
        or (isprocedure(Struct) and not(isclosure(Struct))
            and not(isarray(Struct))) then
            mishap(Msg_ss,[^Struct]);
        else                                                ;;; (4)
            if isproperty(Struct) then                      ;;; (P);
                spr('%p'); save_field(P_prop(Struct));
                save_field(property_size(Struct));
                save_field(property_default(Struct));
                save_field(pdprops(Struct));
                if pdprops(pdpart(updater(Struct)))=
                    '(->Sys$-Prop$-Get)'
                then
                    save_field(false)
                else
                    save_field(updater(Struct));
                endif;
                return;
            elseif isclosure(Struct) then                  ;;; (C)
                spr('%c'); save_field(pdpart(Struct));
                save_field(pdprops(Struct));
                save_field(updater(Struct));
            elseif isarray(Struct) then                    ;;; (A)
                spr('%a');
                spr(boundslist(Struct));                   ;;; (A1)
                save_field(arrayvector(Struct));
                save_field(array_subscrp(Struct));
                lvars (mx,mn) = arrayvector_bounds(Struct);
                spr(mn); spr(mx);
                save_field(isarray_by_row(Struct));
                save_field(pdprops(Struct));
                return;
            elseif isratio(Struct) then
                spr('%r');
                lvars (n,d) = destratio(Struct);
                save_field(n);
                save_field(d);
                return;
            elseif iscomplex(Struct) then
                spr('%z');
                lvars (r,i) = destcomplex(Struct);
                save_field(r);
                save_field(i);
                return;
            else                                           ;;; (G)
                spr(dataword(Struct));
            endif;
            appdata(Struct,save_field); pr(";");
            i -> i_written;
        endif
    else
        mishap('save_data error - this should not occur',
            [^Struct ^Struct_now])
    endif;
enddefine;



/*
save_data(Struct,FileSpec) is the main procedure which writes Struct.
---------------------------------------------------------------------
Struct can be any savable POP-11  data-structure (i.e. item), and FileSpec  is
either a string or an character consumer.

We begin  (1) by  converting  a file  name into  a  consumer, Sink,  which  is
assigned to cucharout (2), so that we normally just "print" structures. Having
suppressed printing quotes on strings (3) we print the header on the save-file
(4), and then (5)  make a property that  will hold the correspondence  between
data-structures and their index  in the save-file and  the property that  will
hold  the  correspondence   between  a  property   occurring  in  the   user's
data-structure and  its association-list.  (A Property  is tricky  to  restore
because we can't just make a property and then update its association list  as
a single object,  so it must  not have forward  references to its  association
list or to its default value).

At (6) we zero  the counts for  the last index-value to  be allocated and  the
most recent index-value to have been  written. Then (7) we call save_field  to
write out a specification of the entire data-structure being saved. This  will
normally be an index of  a structure specified fully  later in the file.  Thus
writing "(35)"  will specify  that  the 35'th  structure  is the  actual  data
structure being saved.

A side-effect of "save_field"  will have been to  create a list of  structures
which have to be  written out, held in  -List_Deferred-. We iterate (8)  first
sorting the list by  index-number so that the  structures are written in  that
order, and then calling save_struct to write out each. Thus the vector {1 [2]
3} might be written out as

    21 vector 1 (22)3 ;

Here 21 is the index of the vector itself, (22) is the index of the list  cell
for [2]. The numbers 1 and 3 are represented by themselves.
Finally (9), no more structures  remain to be written out,  so we tidy up  the
output file and close it.

*/
define lconstant try(Prop,Key,Default)->Val;
  Prop(Key) -> Val;
  if Val then Val else Default
  endif -> Val;
enddefine;


define save_data(Struct,FileSpec) -> P_index;
    lvars Struct,FileSpec;
    dlocal before, class_save, P_index, pr_header, pr_string, pr_trailer,
           new_index, save_field, save_struct;

    newproperty([],128,false,"tmparg") -> P_index;

    if isproperty(FileSpec) then
       try(FileSpec,"before",before) -> before;
       try(FileSpec,"class_save",class_save) -> class_save;
       try(FileSpec,"new_index",new_index) -> new_index;
       try(FileSpec,"save_field",save_field) -> save_field;
       try(FileSpec,"save_struct",save_struct) -> save_struct;
       try(FileSpec,"pr_header",pr_header)   -> pr_header;
       try(FileSpec,"pr_string",pr_string)   -> pr_string;
       try(FileSpec,"pr_trailer",pr_trailer)   -> pr_trailer;
       FileSpec("FileSpec") -> FileSpec;
    endif;
    lvars  Sink = if isstring(FileSpec) then                 ;;; (1)
               discout(FileSpec);
            else FileSpec
            endif;

    dlocal tracing  = false;
    dlocal cucharout = Sink;                            ;;; (2)
    dlocal pop_pr_quotes = false;                       ;;; (3)
    [] -> List_Deferred;
    newproperty([],32,false,"tmparg")  -> P_prop;
    0 -> i_last; 0 -> i_written;                        ;;; (6)
    pr_header(Struct);
    ;;; index(Struct) -> ;    NO NO NO
    until null(List_Deferred) do                        ;;; (8)
        syssort(List_Deferred, before_obj) -> List_Deferred;
        dest(List_Deferred) -> (Struct,List_Deferred);
        save_struct(Struct);
    enduntil;
    pr_trailer(Struct);
enddefine;

define pr_trailer(Struct);
    pr('\n');                                           ;;; (9)
    ;;;pr(termin);
    cucharout(termin);
enddefine;

define pr_header(Struct);
    pr('\nSavedData '); pr('V1\n');                     ;;; (4)
    printf('\'%p\'\n',[%sysdaytime()%]);
    save_field(Struct);                                 ;;; (7)
enddefine;

/*


save_data(false,cucharout) ->;

save_data('can\'t use \\', charout);  ;;; but we can now.
vars circular = [44 fred 'ab' [55 66] last];
circular -> circular.tl.tl.tl.tl.tl;
save_data(circular,'~/circ.tmp')->;
save_data(circular,cucharout)->;
save_data(sin(%23%),'test.tmp')->;
save_data([ [66]],'test.tmp')->;
save_data(66,'test.tmp')->;
save_data('the cat','test.tmp')->;
save_data([%sin(%23%)%],charout);
save_data([%sin(%23%)%],'closure.tmp');
vars P =newproperty([[girl nighean]],34,[query],"perm");
save_data(P,'prop.tmp');
save_data(P,charout);
save_data(newarray([1 2 1 3],nonop +),charout);

save_data("cat",charout);
vars A = newarray([1 2 1 3],nonop +);
save_data(A,charout);
save_data(sin,charout);

/* DOES NOT WORK
npr -> SAVE_DATA$-class_save(string_key);
save_data(['fred'],charout);
*/

save_data(['fred'], newassoc([[pr_string ^npr][FileSpec ^charout]]));
save_data(newarray([1 3],nonop :: (%[end]%)),'array1.tmp') =>

lvars index = SAVE_DATA$-index;


define save_in_array(Struct)->A;
    lvars A = newarray([1 1000], undef);
    define lvars save_s(Struct);
        lvars i = index(Struct);
        Struct -> A(i);
        if class_field_spec(datakey(Struct)) then
            appdata(Struct,index<>erase);
        endif;
    enddefine;

    define lvars header(Struct);
        [% 'saved-data', index(Struct) %] -> pdprops(A) ;

    enddefine;
    save_data(Struct, newassoc([
                [pr_header ^header]
                [save_struct ^save_s]
                [FileSpec ^charout]
                [pr_trailer ^erase]
                ])) -> ;
enddefine;

save_in_array({3 4 [5]}) -> A;
arrayvector(A) =>
 ** {{3 4 [5] } 3 4 [5] 5 [] undef undef undef undef undef ...}
pdprops(A) =>
** [saved-data 1]
*/

/*
Errata and inefficiencies.
--------------------------
We do not check the updater of properties and arrays to make sure the
user has not sneaked in a different one.

Circular properties cause a nasty crash.

We cannot restore content-hashed properties.

It is inefficient to sort the List_Deferred every time we write a structure.

*/

endsection;