-----------------------------------------------------------------------------
/*
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;
|