-----------------------------------------------------------------------------
/*
restore_data.p Robin Popplestone MAR94
This file may be freely copied and modified, provided the attribution above is
preserved or extended as appropriate.
CONTENTS - (Use <ENTER> g to access required sections)
-- Introduction
-- process_file(Rep,PR) applies PR to each record available from Rep
-- check_serial_number compares the serial number of a record with expected val.
-- restore_field reads an entry corresponding to a record-field or vector-entry.
-- restore_list reads the boundslist of an array record.
-- restore_proc_or_key reads a procedure object - array, closure or property
-- restore_key reads information about a key for a data-class
-- restore_object makes a POP-11 record or vector as specified in the file
-- update_proc gives final values to the updatable fields of a procedure
-- update_object fills in forward references in general records/vectors.
-- restore_data(FileName) rebuilds a saved object stored in a file
Introduction
------------
restore_data reads back an object that has been written to disc as a file.
It first checks that the file begins with the word "SavedData". If not,
the file is assumed to be in the old "datafile" format. Otherwise,
a version description is read.
Then it builds the object in two passes.
In pass (1) we make a new POP-11 object (record, vector, closure) for each
record in the file, filling in everything except forward references to other
objects, and building a directory, Object, which maps from the numeric
identifiers of objects in the file to the actual POP object.
In pass (2) we fill in the unfilled forward references.
*/
uses int_parameters;
section SAVE_DATA pop_max_int => restore_data;
lvars procedure Object;
/* These procedures are externally available from within the section */
vars procedure (
class_restore = newassoc([]),
class_update = newassoc([]),
restore_field,
);
/*
process_file(Rep,PR) applies PR to each record available from Rep
----------------------------------------------------------------
Use the repeater Rep to go through a file, applying the procedure
ProcessRecord to operate on objects in the file. The variable -m- holds
the serial number of each record read. These are numbered in the
file, so a consistency check is provided.
*/
define lconstant process_file(Rep,ProcessRecord);
lvars Rep,ProcessRecord;
lvars m=1;
repeat
lvars (Obj,not_last) = ProcessRecord(Rep,m);
unless not_last then return
endunless;
m+1->m;
endrepeat
enddefine;
/*
check_serial_number compares the serial number of a record with expected val.
-----------------------------------------------------------------------------
*/
define lconstant check_serial_number(Rep,m);
lvars Item = Rep();
if Item = termin then return(false)
endif;
unless Item == m then
mishap('Serial number of record does not match',[^Item^m]);
endunless;
true;
enddefine;
/*
stack_fields(Rep,m) stacks up fields read from Rep, pushes a count.
--------------------------------------------------------------------
stack up fields read from Rep until a ";" is read. Put count on
top of stack.
*/
define stack_fields(Rep,m);
lvars Rep,m;
#|repeat
lvars (ExOb_i,is_ptr) = restore_field(Rep,m); ;;; (6)
quitif(is_ptr==termin);
ExOb_i;
endrepeat|#
enddefine;
;;;trace stack_fields;
/*
restore_field reads an entry corresponding to a record-field or vector-entry.
----------------------------------------------------------------------------
Here Rep is the item-repeater for the file. m is the index of the latest
record formed. Any reference to a file-record preceding m can be finalised.
Forward references have to be postponed.
restore_field(Rep,m) -> (Obj,flag)
If the flag = termin then we have read the last field in the object.
If the flag = true then Obj is an integer index to a forward reference
If the flag = false then Obj is the actual finalised POP-11 object
(1) A general POP-11 compound item is represented as a number enclosed in
parentheses, the number being the serial number of its entry in the data-file.
(2) If this serial number is less than that of the current record, then
it can be replaced by the actual POP-11 item, recorded in Object.
(3) A POP-11 word is written out as a string enclosed in both string quotes
and word quotes (e.g. "'fred'" is the word "fred"). This is not bomb-proof,
but should catch most instances.
(4) A semicolon is not a field, but indicates that the last field of
the current record/vector has been read.
(5) An unquoted word is replaced by its value. This is done mostly for
named procedures, and a few quasi-simple objects like false and nil.
(6) Any other item, (primarily a number) stands for itself.
*/
define restore_field(Rep,m); ;;; Not lconstant.
lvars Rep,m;
lvars Ob1 = Rep();
if Ob1 = "(" then ;;; (1) General compound item
lvars Ob2 = Rep();
lvars Cbkt= Rep();
unless isnumber(Ob2) and Cbkt = ")" then
mishap('Illegal form for file-record',
[%Ob1,Ob2,Cbkt%]);
endunless;
if Ob2<= m then Object(Ob2),false ;;; (2) backward reference
else Ob2,true
endif;
elseif Ob1 == """ then ;;; (3) quoted word (as string)
lvars Ob2 = Rep();
lvars Qt = Rep();
unless isstring(Ob2) and Qt = """ then
mishap('Illegal quoted word in file-record',
[%Ob1,Ob2,Qt%]);
endunless;
consword(Ob2), false
elseif Ob1 == ";" then false,termin ;;; (4) ";" terminates
elseif isword(Ob1) then valof(Ob1),false ;;; (5) word - use the value
else Ob1,false; ;;; (6) simple item
endif;
enddefine;
/*
restore_list reads the boundslist of an array record.
--------------------------------------------------
Other lists are handled in the same way as any other record, i.e. they
are build up of pairs flagged by their dataword. We treat boundslists
specially to avoid forward reference, since we cannot update the boundslist
of an array. There is no problem about bounslists because they contain
simple items only.
*/
define lconstant restore_list(Rep);
lvars Rep,Obj;
unless Rep() = "[" then
mishap('List needed-bad save file for restore_data',[])
endunless;
[%until (Rep() ->> Obj) == "]" do
Obj;
enduntil%]
enddefine;
/*
restore_proc_or_key reads a procedure object - array, closure or property
--------------------------------------------------------------
If a record in the file is a procedure object, this is indicated by
a "%" sign in the dataword position, followed by either "a" (for "array")
"c" (for closure) or "p" for property. Named procedures are NOT represented
by separate records, instead their name occurs directly in a field,
save_data having checked that the pdprops matches the valof.
The main problem in restoring these procedure objects is that not all
components are updatable, so that certain forward references have to be
avoided. The save_data procedure, which wrote the data-file in the first
place, knows this and is at pains to avoid these forward references.
At (1) we read the word which indicates whether we have an array,
closure or property, and take the A.. C.. or P.. branches of the conditional.
At (A1) we start reading the various arguments that are to be given to
newanyarray (A8) to reconstitute the array. We read the bounds-list (A2),
the vector of data for the array (A3), the subscripting procedure (A4)
and the index of the first element of the vector -actually- to be used (A5).
The field is skipped - it is the pdprops, restored on update..
At (C1) we treat a closure. We read the -pdpart- (C2). If this is a forward
reference we replace it by -identfn- since we must have a procedure to
make a closure. Later of course this will be updated.
*/
define lconstant read_spec(Rep)->spc;
lvars spc = Rep(), spc_i;
if spc = "[" then
[%until (Rep() ->> spc_i) == "]" do spc_i
enduntil%] -> spc;
endif;
enddefine;
define lconstant restore_proc_or_key(Rep,m) -> Obj;
lvars Rep,m,Obj;
lvars type = Rep(); ;;; (1)
if type == "a" then ;;; (A1) Array
lvars Bounds = restore_list(Rep); ;;; (A2)
lvars (Vec,_) = restore_field(Rep,m); ;;; (A3)
lvars (Sub,_) = restore_field(Rep,m); ;;; (A4)
lvars (i1,_) = restore_field(Rep,m); ;;; (A5)
restore_field(Rep,m) -> ; -> ; ;;; (A6)
lvars (is_ByRow,_) = restore_field(Rep,m); ;;; (A7)
lvars A = newanyarray(Bounds,Vec,Sub,i1-1,is_ByRow); ;;; (A8)
lvars (p,_) = restore_field(Rep,m); ;;; (A9)
A;
elseif type == "c" then ;;; (C1)
consclosure( (lvars (F,is_ptr_F) = restore_field(Rep,m);), ;;; (C2)
if is_ptr_F then identfn
else F
endif,
(restore_field(Rep,m)->;->;),
(restore_field(Rep,m)->;->;),
stack_fields(Rep,m));
elseif type == "p" then
lvars (AList,_) = restore_field(Rep,m);
lvars (size,bad_size) = restore_field(Rep,m);
lvars (default,bad_default) = restore_field(Rep,m);
lvars (pdprop,_) = restore_field(Rep,m);
lvars (udprop,_) = restore_field(Rep,m);
if bad_size then mishap('Bad size spec for property',[^size]);
endif;
if bad_default then mishap('Bad default spec for property',[^default]);
endif;
newproperty([],size,default,"perm")
elseif type == "k" then
lvars (dw,_) = restore_field(Rep,m);
;;; lvars (spc,_) = restore_field(Rep,m);
lvars spc = read_spec(Rep);
conskey(dw,spc);
elseif type == "r" then
lvars (num,_) = restore_field(Rep,m);
lvars (den,_) = restore_field(Rep,m);
num/den;
elseif type == "z" then
lvars (r,_) = restore_field(Rep,m);
lvars (i,_) = restore_field(Rep,m);
r+:i;
else mishap('Illegal procedure type code',[^type]);
endif -> Obj;
Obj->Object(m);
enddefine;
/*
restore_key reads information about a key for a data-class
----------------------------------------------------------
Read the name of a data-class. Form the corresponding key-name and check
that it has a value which is a key. If so, return the key.
*/
define lconstant restore_key(Rep);
lvars ClassName = Rep();
unless isword(ClassName) then
mishap('Word needed for data-class name needed',
[^ClassName]);
endunless;
if ClassName == "%" then ;;; Procedure or key record.
ClassName
else
lvars KeyName = ClassName<>"_key";
lvars Key = valof(KeyName);
unless iskey(Key) then
mishap('Name of data-key required',
[^ClassName^KeyName^Key]);
endunless;
Key;
endif
enddefine;
/*
restore_object makes a POP-11 record or vector as specified in the file
---------------------------------------------------------------------
The argument -Rep- is an item repeater for the input data-file, and m is a
count of the expected serial number for the object to be read. The procedure
returns Obj, the actual POP-11 object which will form part of the final
restored data-structure (although components which are forward references of
it will be later updated), except when the end-of-file is reached, when
not_last is set to -false-.
This procedure will report an error if there is a number-of-fields mismatch
on records. It may also generate an error if the object-identifiers are
numbers too big to fit in a record field or vector entry. Such an error
would otherwise be caught when the entry is updated.
At (1) we check that the expected and actual serial numbers match up
At (2) we read the data-key of the object. If (3) the word "%" is returned
instead, we have a procedure, and call restore_proc_or_key to deal with this case.
Otherwise (4) we read the fields (or components) of the object, stacking
them up, and counting the number of them in -n-.
A prolog term must not have a non-word as last argument, so we treat it
specially.
At (6) we get POPLOG's field-specifier for the data-class and (7) check
that we have a record-class. In this case, the FS is a list, whose length
must match (8) the number of fields we have read. If so, we call the class
constructor (9) to build the record from the stacked components.
Otherwise (10) we have a vector-class, so we rebuild the vector of -n-
elements, using the class-constructor (11).
Finally (12) in either case we record the relationship between serial-number
and the actual object -Obj- that we have build in the property -Object-.
*/
lvars stmk_restore = 'stmk_restore';
define lconstant restore_object(Rep,m) -> (Obj,not_last);
lvars Rep,m,Obj,
not_last = check_serial_number(Rep,m); ;;; (1)
unless not_last then return
endunless;
lvars Key = restore_key(Rep); ;;; (2)
lvars P_restore = class_restore(Key);
if P_restore then
stmk_restore;
P_restore(Rep,m) -> Obj;
Obj -> Object(m);
unless == (/*..*/,stmk_restore) then
mishap('Class restore procedure of wrong arity',
[%P_restore,Obj,Key%]);
endunless;
return;
endif;
if Key == "%" then ;;; (3)
return(restore_proc_or_key(Rep,m) -> Obj);
endif;
lvars n = stack_fields(Rep,m); ;;; (4)
if Key == prologterm_key then ;;; (5)
subscr_stack(n);
prolog_maketerm(/*..*/,n-1) -> Obj; ->;
else
lvars FS = class_field_spec(Key); ;;; (6)
if islist(FS) then ;;; Record class ;;; (7)
unless datalength(Key) = n then ;;; (8)
mishap('Reading record: wrong number of fields',
[%n,Key,FS%]);
endunless;
class_cons(Key)(/*...*/); ;;; Make record ;;; (9)
else ;;; Vector class. ;;; (10)
class_cons(Key)(/*..*/,n); ;;; Make vector ;;; (11)
endif -> Obj;
endif;
Obj->Object(m); ;;; (12)
enddefine;
;;; trace restore_object;
/*
update_proc gives final values to the updatable fields of a procedure
---------------------------------------------------------------------
*/
define lconstant update_proc(Rep,Obj,m);
lvars Rep,m,Obj;
lvars type = Rep();
if type == "a" then ;;; Array
lvars Bounds = restore_list(Rep);
lvars (Vec,_) = restore_field(Rep,m);
lvars (Sub,_) = restore_field(Rep,m);
lvars (i1,_) = restore_field(Rep,m);
restore_field(Rep,m) -> ; -> ;
lvars (is_ByRow,_) = restore_field(Rep,m);
lvars (p,_) = restore_field(Rep,m);
p -> pdprops(Obj);
elseif type == "c" then
lvars (ExPdr,is_ptr_p) = restore_field(Rep,m);
if is_ptr_p then ExPdr -> pdpart(Obj);
endif;
lvars (p,_) = restore_field(Rep,m);
p -> pdprops(Obj);
lvars (u,_) = restore_field(Rep,m);
u -> updater(Obj);
repeat
lvars (ExOb_i,is_ptr) = restore_field(Rep,m),i=1;
if is_ptr = termin then return
endif;
if is_ptr then Object(ExOb_i) -> frozval(i,Obj);
endif;
i+1->i;
endrepeat;
elseif type == "p" then ;;; property
lvars (AList,_) = restore_field(Rep,m);
lvars (size,bad_size) = restore_field(Rep,m);
lvars (default,bad_default) = restore_field(Rep,m);
lvars (pdprop,_) = restore_field(Rep,m);
pdprop -> pdprops(Obj);
lvars Pair;
for Pair in AList do
hd(tl(Pair)) -> Obj(hd(Pair));
endfor;
lvars (u,_) = restore_field(Rep,m);
if u then u -> updater(Obj);
endif;
;;; elseif type == "k" then ;;; key
;;; lvars (dw,_) = restore_field(Rep,m);
;;; lvars spc = read_spec(Rep);
elseif type == "z" or type=="r" then ;;; complex number/ratio
lvars (_,_) = restore_field(Rep,m); ;;; fields ok
lvars (_,_) = restore_field(Rep,m); ;;; so ignore.
else mishap('Illegal procedure type code',[^type]);
endif ;;;-> Obj;
;;; Obj->Object(m);
enddefine;
/*
update_object fills in forward references in general records/vectors.
---------------------------------------------------------------------
We read the serial number(1), exiting (2) if we are at the end-of-file At (3),
having made m big to indicate that there are effectively no forward references
on the second pass, we read the dataword, normally converted to the
corresponding key. "%" indicates a procedure, which is handled by separate
code (P).
Otherwise we stack up the fields on the input, and use them to -fill-
the data-structure.
*/
define lconstant update_object(Rep,m) -> (Obj,not_last);
lvars Rep,m,Obj = Object(m), ;;; (1)
not_last = check_serial_number(Rep,m);
unless not_last then return ;;; (2)
endunless;
pop_max_int -> m; ;;; (3)
lvars Key = restore_key(Rep), i = 1; ;;; (4)
lvars P_update = class_update(Key);
if P_update then
P_update(Obj,Rep,m) -> Obj;
return;
endif;
if Key == "%" then ;;; (P)
update_proc(Rep,Obj,m); return;
elseif Key == undef_key then
stack_fields(Rep,m) -> ; -> ;
return;
elseif Key == prologterm_key then
lvars n = stack_fields(Rep,m) ;
for i from n-1 by -1 to 1 do
-> fast_prolog_arg(i,Obj);
endfor;
-> prolog_functor(Obj);
return;
else fill((stack_fields(Rep,m)->),Obj) -> ;
endif;
enddefine;
/*
restore_data(FileName) rebuilds a saved object stored in a file
----------------------------------------------------------------
The default syntax of the file is described in HELP * restore_data.
To restore an object we begin by making a repeater procedure which will give
us items (1). We use this to read the header, version.
If there is no header, we assume we have a datafile
and date (4..5). We
enable the reading of long strings (5) and create a property (6) which will
hold the mapping between object identifiers in the file and the actual POP-11
objects which are built. At (7) we use restore_field to read the identifier
of the object which is -actually being restored- (as opposed to its
sub-objects). If this is simple or quasi-simple the actual value will
be returned and the file will in fact end here, although we do not need to
worry about that. At (8) we take the first pass through the rest of the
input file to build up the directory of objects in -Object-. See below
for what happens then.
*/
;;; get_rep gets a character repeater for a file or resets a stringin.
define lvars get_rep(Spec_Rep);
if isstring(Spec_Rep) then discin(Spec_Rep)
elseif isclosure(Spec_Rep)
and pdpart(Spec_Rep) = pdpart(stringin(''))
then 1 -> back(frozval(1,Spec_Rep));
Spec_Rep
else mishap('cant use this to restore data', [^Spec_Rep]);
endif;
enddefine;
define restore_data(FileName)->Obj_out;
lvars FileName;
lvars Rep1 = incharitem(get_rep(FileName)); ;;; (1) Make item repeater
lvars Hdr = Rep1(); ;;; (2) Read header
unless Hdr = "SavedData" then ;;; (3) Compatibility
popval([datafile(^FileName)]) -> Obj_out; ;;; with datafile
npr('*** File restored using datafile *** ');
npr(' You need to update your saved-data ');
return;
endunless;
lvars Version = Rep1(); ;;; (4) and version
lvars Date = Rep1(); ;;; and date
dlocal pop_longstrings = true; ;;; (5)
dlocal Object = newassoc([]); ;;; (6)
lvars (Obj,is_index) = restore_field(Rep1,0) ; ;;; (7)
process_file(Rep1,restore_object); ;;; (8) First pass
/*
This is the second pass through the input. We proceed as before...
*/
lvars Rep2 = incharitem(get_rep(FileName)); ;;; (9)
Rep2()->; Rep2()->; Rep2()->; ;;; (10) Discard info
lvars (_,_) = restore_field(Rep2,0);
process_file(Rep2,update_object); /* Pass (2) */
if is_index then Object(Obj)
else Obj
endif -> Obj_out;
enddefine;
/*
;;; This does in fact work, but not with the -example- macro.
save_data('can\'t use \\ and \^A','string.tmp');
datalist(restore_data('string.tmp'))=>
** [99 97 110 39 116 32 117 115 101 32 92 32 97 110 100 32 1]
;;; Check datafile downward compatibility.
[2 3 4] -> datafile('datafile.tmp');
*** File restored using datafile ***
restore_data('datafile.tmp')=>
** [2 3 4]
example save_data
;;; Saving a single quasi-simple item.
save_data(false,'false.tmp') ->;
restore_data('false.tmp')=>
** <false>
;;; Circular list
vars circular = [44 fred 'ab' [55 66] last];
circular -> circular.tl.tl.tl.tl.tl;
save_data(circular,'circ.tmp')->;
vars L = restore_data('circ.tmp'); ;;; Infinite list - beware.
vars i;
pr('** '); for i from 1 to 10 do spr(L(i)); endfor
** 44 fred ab [55 66] last 44 fred ab [55 66] last
;;; Integers
save_data(654,'int.tmp') ->;
restore_data('int.tmp')=>
** 654
;;; Floats
true -> popdprecision;
save_data(sin(0.1), 'float.tmp') ->;
vars x = restore_data('float.tmp');
pr('\n**'); prnum(x,1,22);
sin(0.1)=>
;;; Negative floats
save_data(-1.0,'float.tmp')->;
restore_data('float.tmp')=>
** -1.0
save_data(4/5,'ratio.tmp')->;
restore_data('ratio.tmp')=>
** 4/5
;;; Complex numbers
save_data(sqrt(-1),'complex.tmp')->;
restore_data('complex.tmp')=>
** 0.0_+:1.0
;;; Simple list
save_data([2 3],'list.tmp') ->;
restore_data('list.tmp')=>
** [2 3]
save_data({[44][66]},'vector.tmp') ->;
restore_data('vector.tmp')=>
;;; Partial application.
save_data(sin(%23%),'partapply.tmp') ->;
vars S = restore_data('partapply.tmp');
pdpart(S) =>
** <procedure sin>
datalist(S)=>
** [23]
;;; Updater and pdpart of closures.
vars S = sin(%45,84%);
cos -> updater(S);
'funny' -> pdprops(S);
save_data(S,'partapply_S.tmp') ->;
vars S_read = restore_data('partapply_S.tmp');
S_read.datalist=>
** [45 84]
S_read.updater=>
** <procedure cos>
S_read.pdprops=>
** funny
save_data(23,'simp.tmp') ->;
restore_data('simp.tmp')=>
** 23
save_data("fred",'word.tmp');
vars (w,_) = restore_data('word.tmp');
isword(w) =>
save_data('the cat','string.tmp') ->;
restore_data('string.tmp')=>
** the cat
vars P =newproperty([[girl nighean]],34,[3 query],"perm");
'Gaelic' -> pdprops(P);
save_data(P,'prop.tmp') ->;
vars P_r = restore_data('prop.tmp');
P_r=>
datalist(P_r)=> ;;; more entries will appear in random order.
** [[girl nighean]]
P_r("fred") =>
** [3 query]
save_data(newarray([1 2 1 3],nonop +),'array.tmp') ->;
vars A = restore_data('array.tmp');
A =>
** <array [1 2 1 3]>
datalist(A) =>
** [2 3 3 4 4 5]
save_data(newarray([1 3],nonop :: (%[end]%)),'array1.tmp') ->;
vars A1 = restore_data('array1.tmp');
A1 =>
** <array [1 3]>
datalist(A1) =>
** [[1 end] [2 end] [3 end]]
save_data({%undef,34%},'undef.tmp') ->;
restore_data('undef.tmp') =>
;;; User defined data-structures.
defclass person {prs_name, prs_address, prs_age :byte, prs_sex :1 };
save_data(consperson('fred','maryhill',34,1),charout);
save_data(consperson('fred','maryhill',34,1),'keys.tmp');
restore_data('keys.tmp') =>
save_data(prolog_maketerm(9,"a","f",2),'prolog.tmp');
vars t = restore_data('prolog.tmp');
datalist(t) =>
** 9 a f
endexample;
/* This example checks that any string can be saved */
lvars i;
vars S_full = consstring(#|for i from 0 to 255 do i endfor |#);
save_data(S_full,'string_fl.tmp');
vars S_r = restore_data('string_fl.tmp');
for i from 0 to 255 do unless S_r(i+1) = i then
mishap('string entry wrong',[^i]);
endunless
endfor;
;;; This example will crash ---- circularity through property.
vars P =newproperty([[girl nighean]],34,[query],"perm");
P -> P("fred");
save_data(P,'prop_funny.tmp');
;;; This example uses affine spaces.
save_data(pt3(1,2,3),'point.tmp');
restore_data('point.tmp') =>
save_data([0.0],charout)=>
save_data(sqrt(-1),charout);
*/
;;; trace restore_field;
endsection;
|