Trailing-Edge
-
PDP-10 Archives
-
decuslib20-03
-
decus/20-0078/libsim/dbm.sim
There is 1 other file named dbm.sim in the archive. Click here to see a list.
OPTIONS(/external);
EXTERNAL REF (Infile) PROCEDURE findinfile;
EXTERNAL REF (Outfile) PROCEDURE findoutfile;
EXTERNAL TEXT PROCEDURE conc,upcase,frontstrip,rest,checkextension;
EXTERNAL CHARACTER PROCEDURE fetchar,findtrigger;
EXTERNAL LONG REAL PROCEDURE scanreal;
EXTERNAL INTEGER PROCEDURE checkreal,checkint,scanint,ilog;
EXTERNAL BOOLEAN PROCEDURE menu;
EXTERNAL CLASS safeio,dbmtxt;
dbmtxt CLASS dbm;
VIRTUAL: PROCEDURE savestruc;
BEGIN
REF(Directfile) d__file;
REF (record) old__rec;
REF (record) ARRAY rpool(-1:200);
INTEGER rpooltop,n__spa,oflowbase,oflowtop,gen_key;
INTEGER s_size,prev_syn,max_load,pstart;
INTEGER nr_record,nr_addpool,nr_get,nr_lookup;
INTEGER nr_loct,nr_locr,nr_load,nr_store,nr_newpool;
BOOLEAN makenewfile,nameonly,storenewfile,do_not_buffer;
BOOLEAN postpone_,break_do,break_map;
TEXT last_d_image,store_buff,blankbuff,blank2,undefined;
TEXT ARRAY typtext[1:7],noargs[1:1];
REF (rspec) current_spec,spec__spec,newrspec;
INTEGER rsptop,maxrsize,rpooltop1,rpoolmax,rpoolmax2;
REF (rspec) ARRAY recordspec(1:30);
CLASS record(spec,avalues);
REF (rspec) spec; TEXT ARRAY avalues;
!
spec pointer to rspec object with specification for
this record type
avalues text array with attribute values
;
VIRTUAL: TEXT PROCEDURE getkey; REF (record) PROCEDURE load;
PROCEDURE store;
BEGIN INTEGER dbskey,type_;
TEXT syn_,set_; BOOLEAN changed;
TEXT PROCEDURE getkey; getkey:-avalues(spec.keypos);
REF (record) PROCEDURE load(t); TEXT t;
!--------------------------------------------------------
Load elements from text T to array AVALUES.
Elements are either numbers or text between delimiters.
Arrays become just a single textstring.
--------------------------------------------------------;
BEGIN INTEGER k,i,max; CHARACTER c,cc;
max:=spec.adim; t:-conc(t,blank2);
IF max_load > 0 AND max_load < max THEN max:=max_load;
BEGIN TEXT ARRAY avalues(1:max+1);
FOR k:=1 STEP 1 UNTIL max DO
BEGIN
t:-frontstrip(t);
IF t == NOTEXT THEN GOTO fin;
IF spec.atypes(k) < 3 THEN c:=' ' ELSE c:=t.Getchar;
cc:=nullc;
i:=t.Pos; WHILE cc \= c DO cc:=t.Getchar;
avalues(k):-t.Sub(i,t.Pos-i-1);
t:-t.Sub(t.Pos,t.Length-t.Pos+1);
END;
fin: load:-NEW record(spec,avalues);
END;
END of load;
PROCEDURE store;
!--------------------------------------------------------
Put elements from AVALUES into one single text.
Separate treatment of arrays, numbers and texts.
Then use STORERECORD to store total record in database.
--------------------------------------------------------;
BEGIN TEXT s,u,uu; INTEGER k,n,max;
dbskey:=lookup(getkey,spec.rname);
addrpool(dbskey,THIS record);
spec.dirfile.Locate(dbskey);
store_buff:=blankbuff;
s:-store_buff; max:=spec.adim;
FOR k:=1 STEP 1 UNTIL max DO
BEGIN
u:-avalues(k);
IF spec.atypes(k) \= 3 THEN
BEGIN ! open code for putnumber(avalues(k),s);
IF spec.atypes(k) > 3 AND u.Sub(1,1) \= slash THEN
! IF ARRAY FIELD MAKE SURE IT IS DELIMITED PROPERLY;
BEGIN
uu:-conc(u,slash);
u:-conc(slash,uu);
END;
IF s.Length-s.Pos < u.Length+ 3 THEN
BEGIN
n:=s.Pos;
s:-conc(s,Blanks(u.Length+4)); s.Setpos(n);
END;
s.Sub(s.Pos,u.Length):=u; s.Setpos(s.Pos+1+u.Length);
END ELSE
BEGIN ! open code for putt(avalues(k),s);
IF u.Length = 0 THEN u:-Blanks(1);
IF s.Length-s.Pos < u.Length+3 THEN
BEGIN ! make string longer if not enough space left;
n:=s.Pos;
s:-conc(s,Blanks(u.Length+4)); s.Setpos(n);
END;
! transfer string surrounded by delimiters;
s.Sub(s.Pos,1):=delim; s.Sub(s.Pos+1,u.Length):=u;
s.Sub(s.Pos+1+u.Length,1):=delim;
s.Setpos(s.Pos+3+u.Length);
END;
END;
IF set_ =/= NOTEXT THEN s:-addstruc(s,set_);
storerecord(spec.dirfile,conc(blank2,syn_),s);
END of store;
syn_:-Blanks(s_size);
nr_record:=nr_record+1;
END of record;
record CLASS rspec(rname,terms,
key,base,size,keypos,adim,anames,atypes);
TEXT rname,terms,key;
INTEGER base,size,keypos,adim;
TEXT ARRAY anames; INTEGER ARRAY atypes;
!
rname name of record
terms all attributes as a string
key key attribute
base start location for primary data area
size size of primary data area
keypos position of key among parameters
adim number of attributes
anames text array containing all attribute names
atypes integer array with types: 1=integer, 2=real, 3=text
;
BEGIN REF (Directfile) dirfile; REF (record) prototype;
REF (rspec) PROCEDURE load(t); TEXT t;
!--------------------------------------------------------
t is total record. Its elements are loaded into the
corresponding attributes of the RSPEC object.
--------------------------------------------------------;
BEGIN REF (rspec) r;
REF (text__arr) n1; REF (int__arr) t1;
TEXT r_rname,r_terms,r_key;
INTEGER r_base,r_size,r_keypos,r_adim;
t_t:-conc(t,blank2);
r_rname:-nexttext; r_terms:-nexttext;
r_key:-nexttext; r_base:=nextint; r_size:=nextint;
r_keypos:=nextint; r_adim:=nextint;
n1:-nexttarr; t1:-nextiarr;
BEGIN
TEXT ARRAY r_anames[1:r_adim+1],avalues[1:n__spa+1];
INTEGER ARRAY r_atypes[1:r_adim+1];
! create avalues vector by reading t again;
t.Setpos(1);
FOR k__:=1 STEP 1 UNTIL n__spa DO
BEGIN
avalues(k__):-locfield(t,1);
IF k__ < n__spa THEN t:-t.Sub(next__pos,t.Length-next__pos+1);
END;
r:-NEW rspec(spec__spec,avalues,r_rname,r_terms,r_key,
r_base,r_size,r_keypos,r_adim,r_anames,r_atypes);
FOR k__:=1 STEP 1 UNTIL r_adim DO
BEGIN
r_anames(k__):-n1.vekt(k__); r.atypes(k__):=t1.vekt(k__);
END;
END;
load:-r;
END of load;
PROCEDURE store;
INSPECT spec.dirfile DO
BEGIN TEXT s;
!--------------------------------------------------------
Accumulate all attributes of RSPEC in one text S, then
store S into the database.
--------------------------------------------------------;
dbskey:=lookup(rname,"RSPEC");
Locate(dbskey);
s:-store_buff; s:=blankbuff;
putt(rname,s); putt(terms,s); putt(key,s);
puti(base,s); puti(size,s); puti(keypos,s); puti(adim,s);
putnumber(slash,s);
FOR k__:=1 STEP 1 UNTIL adim DO putt(anames(k__),s);
putnumber(slash,s); putnumber(slash,s);
FOR k__:=1 STEP 1 UNTIL adim DO puti(atypes(k__),s);
putnumber(slash,s);
storerecord(THIS Directfile,conc(blank2,syn_),s);
END of store;
rsptop:=rsptop+1; recordspec(rsptop):-THIS rspec;
dirfile:-d__file;
END of rspec;
record CLASS lrecord;
BEGIN
REF (ownership) ownersets; REF (membership) membersets;
REF (lrecord) PROCEDURE load(t); TEXT t;
!-------------------------------------------------------
The same as for RECORD, except that structural
information is separated and saved in the attribute set_
for later reference.
-------------------------------------------------------;
BEGIN INTEGER k,i,max; TEXT u; REF (lrecord) r;
CHARACTER c,cc;
max:=spec.adim; substruc(t,u);
t:-conc(t,blank2);
BEGIN TEXT ARRAY avalues(1:max+1);
FOR k:=1 STEP 1 UNTIL max DO
BEGIN
t:-frontstrip(t);
IF t == NOTEXT THEN GOTO fin;
IF spec.atypes(k) < 3 THEN c:=' ' ELSE c:=t.Getchar;
cc:=nullc;
i:=t.Pos; WHILE cc \= c DO cc:=t.Getchar;
avalues(k):-t.Sub(i,t.Pos-i-1);
t:-t.Sub(t.Pos,t.Length-t.Pos+1);
END;
fin: r:-NEW lrecord(spec,avalues); r.set_:-u;
load:-r;
END;
END of load;
END;
!-------------------------------------------------------
Data structures used to create chains of set-
occurences in core.
-------------------------------------------------------;
CLASS ownership(setname,firstmemb,next);
TEXT setname;
REF (lrecord) firstmemb; REF (ownership) next;;
CLASS membership(setname,ownpoint,nextmemb,next); TEXT setname;
REF (lrecord) ownpoint,nextmemb; REF (membership) next;;
!------------------------------------------------------
Procedures used to add and remove structural part
of record from data part.
------------------------------------------------------;
TEXT PROCEDURE addstruc(t,u); TEXT t,u;
BEGIN TEXT v,w;
w:-t.Strip;
t:-conc(w,Copy(" "));
w:-Copy(" *"); w.Sub(2,3).Putint(t.Length);
addstruc:-conc(t,conc(u,w));
END of addstruc;
PROCEDURE substruc(t,u); NAME t,u; TEXT t,u;
BEGIN INTEGER k;
u:-t.Sub(t.Length,1); IF u = "*" THEN
BEGIN
k:=t.Sub(t.Length-4,4).Getint;
u:-Copy(t.Sub(k,t.Length-4-k));
t:-t.Sub(1,k);
END ELSE u:-NOTEXT;
END of substruc;
PROCEDURE addrpool(n,r); INTEGER n; REF (record) r;
!-------------------------------------------------------
One record r is added to the array RPOOL over recently
accessed records.
Its place in RPOOL is computed from its directfile
location.
When RPOOL is full, old records are removed from
it to make place.
-------------------------------------------------------;
IF \ do_not_buffer AND locaterec(n) < 0 THEN
BEGIN INTEGER k;
nr_addpool:=nr_addpool+1;
k:=Mod(n,rpooltop1);
IF rpool(k) == NONE THEN rpool(k):-r ELSE
BEGIN
IF rpooltop > rpoolmax THEN
BEGIN
IF postpone_ THEN
FOR k__:=0 STEP 1 UNTIL rpooltop DO
BEGIN REF (record) rr;
rr:-rpool(k__); IF rr =/= NONE THEN
BEGIN IF rr.changed THEN savestruc(rr); END;
END;
IF Mod(nr_newpool,3) = 0 THEN k__:=0 ELSE k:=rpooltop1;
FOR k__:=k__ STEP 1 UNTIL rpooltop DO
rpool(k__):-NONE;
nr_newpool:=nr_newpool+1;
rpooltop:=rpooltop1;
END;
rpooltop:=rpooltop+1; rpool(rpooltop):-r;
END;
END of addrpool;
PROCEDURE doforeach(rtyp,treat); NAME rtyp;
!------------------------------------------------------
Iteration procedure used to process all records of
a particular type, calling an arbitrary procedure
TREAT for each record.
------------------------------------------------------;
TEXT rtyp; PROCEDURE treat;
BEGIN REF (rspec) r; INTEGER k,n,max;
REF (record) p,refrec;
REF(record) PROCEDURE getsynrec;
BEGIN TEXT u;
u:-p.syn_;
IF u \= undefined THEN getsynrec:-getrec(u.Getint,refrec);
END of getsynrec;
r:-getrecordspec(rtyp); IF r == NONE THEN
BEGIN
Outtext("ERROR: doforeach, record type undefined ");
Outtext(rtyp); Outimage; GOTO fin;
END;
max:=r.base+r.size-1;
FOR k:=r.base STEP 1 UNTIL max DO
BEGIN
refrec:-r.prototype;
n:=k; p:-getrec(n,refrec);
IF p =/= NONE THEN
BEGIN treat(p); IF break_do THEN GOTO fin; p:-getsynrec; END;
WHILE p =/= NONE DO
BEGIN
treat(p); IF break_do THEN GOTO fin;
p:-getsynrec;
END;
END;
fin:
break_do:=FALSE;
END of doforeach;
REF (record) PROCEDURE getrec(rgetpos,refrec);
NAME rgetpos;
INTEGER rgetpos; REF (record) refrec;
!-----------------------------------------------------
rgetpos is location for a record which is read as a
whole and interpreted by the LOAD procedure of the
record refrec.
NONE is returned if the record is empty or has been
marked as deleted.
-----------------------------------------------------;
BEGIN TEXT link,s; CHARACTER c; REF(record) r;
d__file.Locate(rgetpos); IF \d__file.Endfile THEN
BEGIN
gr1: d__file.Inimage;
s:-d__file.Image.Strip;
gr0:
IF s.Sub(1,1) = "+" THEN
BEGIN ! record has been deleted;
rgetpos:=s.Sub(pstart-s_size,s_size).Getint;
d__file.Locate(rgetpos); GOTO gr1;
END;
IF s.Sub(1,1) = "-" THEN s:-NOTEXT;
IF s =/= NOTEXT AND s \= "/*" THEN
BEGIN
IF s.Length > 0 THEN
BEGIN IF s.Sub(1,1).Getchar = nullc THEN GOTO fin; END;
link:-Copy(s.Sub(1,pstart-1));
s:-loadrecord(s);
r:-refrec.load(s);
r.syn_:-link.Sub(pstart-s_size,s_size);
r.dbskey:=rgetpos;
link:-link.Sub(1,2);
IF link \= " " THEN r.type_:=link.Getint;
addrpool(rgetpos,r);
getrec:-r;
END;
END;
fin:
END of getrec;
REF (record) PROCEDURE get(rkey,rtype);
NAME rkey,rtype; TEXT rkey,rtype;
!----------------------------------------------------
Load a record with given key and type.
First check if already loaded and saved in array
RPOOL of active records.
Then compute pseudo-adress, see if key is same as
searched, if not follow chain of synonym records
until found, or if not found return NONE.
----------------------------------------------------;
BEGIN REF(record) r,rr,refr; TEXT u,key2;
INTEGER n,k;
nr_get:=nr_get+1;
prev_syn:=0;
n:=loctype(rkey,rtype,refr);
nextsym: k:=locaterec(n); IF k >= 0 THEN
BEGIN COMMENT record found among those treated before;
r:-rpool(k); IF r.spec =/= NONE THEN GOTO compare;
END;
r:-getrec(n,refr);
IF r == NONE THEN GOTO fin;
r.dbskey:=n;
compare: key2:-r.getkey;
IF rkey = key2 THEN
BEGIN
IF k> 0 THEN
BEGIN
rr:-rpool(k); IF rr.spec == NONE THEN
BEGIN
rpool(k):-r; IF r IN lrecord THEN
BEGIN REF (lrecord) l1,l2;
l1:-r QUA lrecord; l2:-rr QUA lrecord;
l1.ownersets:-l2.ownersets; l1.membersets:-l2.membersets;
END;
END;
END;
get:-r; GOTO fin;
END;
u:-r.syn_;
IF u = undefined THEN get:-NONE ELSE
BEGIN prev_syn:=n; n:=u.Getint; GOTO nextsym; END;
fin:
END of get;
INTEGER PROCEDURE lookup(t,rtype);
NAME t,rtype; TEXT t,rtype;
!-----------------------------------------------------
When a record is to be stored this procedure is called
to compute a location for it.
Analoguous to GET, but if record is NOT found a
location to an empty place is returned as value,
if found the location for the previous record
is returned.
-----------------------------------------------------;
BEGIN INTEGER n,k; REF (record) r,refr;
TEXT key2,u;
nr_lookup:=nr_lookup+1;
old__rec:-NONE;
n:=loctype(t,rtype,refr);
nextsym: k:=locaterec(n); IF k >= 0 THEN
BEGIN COMMENT record found among those treated before;
r:-rpool(k); IF r.spec =/= NONE THEN GOTO compare;
END;
r:-getrec(n,refr);
IF r == NONE THEN BEGIN lookup:=n; GOTO fin; END;
compare: key2:-r.getkey; IF t = key2 THEN
BEGIN COMMENT overwrite previous record;
old__rec:-r;
lookup:=n; GOTO fin;
END;
u:-r.syn_; IF u = undefined THEN
BEGIN COMMENT create one more overflow record;
! modify synonym pointer ;
BEGIN d__file.Locate(n); d__file.Inimage; END;
r.syn_.Putint(oflowtop);
d__file.Image.Sub(pstart-s_size,s_size):=r.syn_;
d__file.Locate(n); d__file.Outimage;
lookup:=oflowtop; oflowtop:=oflowtop+1;
END ELSE
BEGIN n:=u.Getint; GOTO nextsym; END;
fin:
END of lookup;
INTEGER PROCEDURE loctype(key,rtype,refr);
NAME refr;
TEXT key,rtype; REF (record) refr;
!-----------------------------------------------------
Check that record type RTYP is defined, if so compute
from KEY a pseudo-adress within data base area for
that record type.
-----------------------------------------------------;
BEGIN INTEGER n; REF (rspec) r;
nr_loct:=nr_loct+1;
IF storenewfile THEN r:-newrspec ELSE
r:-getrecordspec(rtype); IF r == NONE THEN
BEGIN
Outtext("ERROR: undefined record type: ");
outline(rtype);
END ELSE
BEGIN
refr:-r.prototype;
loctype:=dbadr(key,r.size,r.base);
END;
END of loctype;
INTEGER PROCEDURE locaterec(n); INTEGER n;
!-----------------------------------------------------
See if a record with start location=N is an element
in RPOOL, the buffer of active records.
If so return its index in RPOOL else ZERO.
It is located first by hashing on N, and if this
fails by sequential search from RPOOLTOP1
and upwards.
-----------------------------------------------------;
BEGIN
locaterec:=-1;
IF \makenewfile THEN
BEGIN INTEGER k;
nr_locr:=nr_locr+1;
IF n = 0 THEN GOTO fin;
k:=Mod(n,rpooltop1);
IF rpool(k) == NONE THEN GOTO fin;
IF rpool(k).dbskey = n THEN
BEGIN locaterec:=k; GOTO fin; END;
FOR k:=rpoolmax+2 STEP 1 UNTIL rpoolmax2 DO
BEGIN
IF rpool(k).dbskey = n THEN
BEGIN locaterec:=k; GOTO fin; END;
END;
k:=rpooltop1;
WHILE k<rpooltop DO
BEGIN
k:=k+1;
IF rpool(k) =/= NONE THEN
BEGIN
IF rpool(k).dbskey = n THEN
BEGIN locaterec:=k; GOTO fin; END;
END;
END;
fin:
END;
END of locaterec;
PROCEDURE defaultparms;
!-----------------------------------------------------
Set defaultparameters(internal for system). Create
an RSPEC describing a recordspecification which is
needed to load the other recordspecifications from
file.
-----------------------------------------------------;
BEGIN
INTEGER k,nattr; TEXT t,u;
TEXT ARRAY attrarr[1:12]; INTEGER ARRAY typarr[1:12];
cdelim := '"'; delim :- Copy("""");
split_char:=','; blank2:-Copy(" ");
typtext(1):-Copy("INTEGER"); typtext(2):-Copy("REAL");
typtext(3):-Copy("TEXT");
typtext(4):-Copy("INTEGER ARRAY");
typtext(5):-Copy("REAL ARRAY");
typtext(6):-Copy("TEXT ARRAY");
rpooltop:=rpooltop1:=30;
rpoolmax:=38; rpoolmax2:=39;
pstart:=8; s_size:=5;
maxrsize := rlength+100;
store_buff:-Blanks(maxrsize);
blankbuff:-Blanks(maxrsize);
undefined:-Blanks(s_size);
slash:-Copy("/");
t:-Copy("RNAME,TERMS,KEY,BASE,SIZE,KEYPOS,ADIM,ANAMES,ATYPES");
n__spa:=split(t,attrarr);
u:-Copy("333111164 ");
FOR k:=1 STEP 1 UNTIL n__spa DO typarr(k):=u.Sub(k,1).Getint;
spec__spec:-NEW rspec(NONE,attrarr,Copy("RSPEC"),t,
Copy("RNAME"),2,8,1,n__spa,attrarr,typarr);
spec__spec.spec:-spec__spec;
spec__spec.prototype:-spec__spec;
END of defaultparms;
REF (rspec) PROCEDURE getrecordspec(rcname);
NAME rcname;TEXT rcname;
!-----------------------------------------------------
Locate RSPEC object with name RCNAME in array
RECORDSPEC where all such objects are stored
when the system is initialized.
-----------------------------------------------------;
BEGIN INTEGER k;
k:=1; WHILE k <= rsptop DO
BEGIN COMMENT see if record already accessed;
IF rcname = recordspec(k).rname THEN
BEGIN getrecordspec :- recordspec(k); GOTO fin; END;
k:=k+1;
END;
fin:
END of getrecordspec;
TEXT PROCEDURE loadrecord(t); TEXT t;
!----------------------------------------------------
t is first part (image) of external record if there
are continuations, load these recursively until
finally the entire logical external record is returned
as value.
The global variable LAST_D_IMAGE is also set to
point on this record.
----------------------------------------------------;
BEGIN TEXT tx;
nr_load:=nr_load+1;
IF t.Length < rlength THEN
last_d_image:-t.Sub(pstart,t.Length-pstart+1).Strip ELSE
BEGIN
tx:-t.Sub(t.Length-10,6);
d__file.Locate(tx.Getint);
tx:-Copy(t.Sub(pstart,t.Length-pstart-10));
d__file.Inimage;
last_d_image:-conc(tx,loadrecord(d__file.Image.Strip));
END;
loadrecord:-last_d_image;
END of loadrecord;
PROCEDURE storerecord(d,f,t); REF(Directfile) d; TEXT f,t;
!-----------------------------------------------------
File D is located to where an external logical
record is to start.
Write it , and if needed write continuation records
(recursively) in overflowarea and link
them together.
A continuation pointer is a number stored at the end
of the image, and the last character is then set to ':'.
-------------------------------------------------------;
BEGIN INTEGER n,m; TEXT tx;
INSPECT d DO
BEGIN
nr_store:=nr_store+1;
Image.Sub(1,pstart-1):=f;
m:=Image.Length-pstart+1; t:-t.Strip; n:=t.Length;
IF n >= m THEN
BEGIN
Image.Sub(Image.Length-10,9):=Blanks(9);
Image.Sub(Image.Length-10,6).Putint(oflowtop);
Image.Sub(Image.Length,1).Putchar(':');
m:=m-11;
tx:-t.Sub(1,m);
END ELSE tx:-t;
Image.Sub(pstart,m):=tx; Outimage;
IF n >= m THEN
BEGIN
d.Locate(oflowtop); oflowtop:=oflowtop+1;
storerecord(d,Blanks(pstart-1),t.Sub(m+1,n-m));
END;
END;
END of storerecord;
PROCEDURE loadspec;
!------------------------------------------------------
Read OFLOWTOP and GEN_KEY from first image of data base.
Make sure that OFLOWTOP points to top of file.
Load all record-specifications.
They are automatically saved in array RECORDSPEC
when an RSPEC object is created (See above class RSPEC,
its procedure LOAD and its class body).
------------------------------------------------------;
BEGIN REF (record) r; INTEGER k;
PROCEDURE spec_in(r); REF (rspec) r;
BEGIN r.prototype:-NEW record(r,r.anames); END;
INSPECT d__file DO
BEGIN
Locate(1); Inimage;
oflowtop:=Inint; gen_key:=Inint;
gen_key:=gen_key+100//100*101; ! increment to next multiple of 100;
k:=oflowtop;
! make sure that proper top of file is known;
WHILE \Endfile DO
BEGIN Locate(k); Inimage; k:=k+1; END;
oflowtop:=k-1;
END;
spec__spec.dirfile:-d__file;
doforeach("RSPEC",spec_in);
END of loadspec;
PROCEDURE put_record(rtyp,r); REF (rspec) rtyp; TEXT r;
!-------------------------------------------------------
Store text R as an external record of type RTYP.
Produce its key, compute its location and store by
calling STORERECORD.
-------------------------------------------------------;
BEGIN
TEXT key;
r.Setpos(1); key:-locfield(r,rtyp.keypos);
IF key == NOTEXT THEN
outline("Put_record: bad record !") ELSE
BEGIN
d__file.Locate(lookup(key,rtyp.rname));
storerecord(d__file,Blanks(pstart-1),r);
END;
END of put_record;
INTEGER PROCEDURE next_key;
BEGIN ! produce next unique number;
gen_key:=gen_key+1; next_key:=gen_key;
END of next_key;
PROCEDURE closebase;
!-------------------------------------------------------
Check that all records in RPOOL are properly stored
externally.
Update first image which contains pointer to current
top of file and current number for generated data
base keys.
Close file, print statistics over calls to the most
frequent internal procedures.
-------------------------------------------------------;
BEGIN INTEGER n; REF (record) r;
INSPECT d__file DO
BEGIN
FOR n:=0 STEP 1 UNTIL rpooltop DO
BEGIN
r:-rpool(n);
IF r =/= NONE THEN
BEGIN IF r.changed THEN savestruc(r); END;
END;
Locate(1); Inimage;
n:=Image.Sub(1,6).Getint;
IF n < oflowtop THEN
BEGIN
Image.Sub(1,6).Putint(oflowtop);
Image.Sub(7,6).Putint(gen_key); ! save current unique number;
Locate(1); Outimage;
END;
Setpos(1); Close;
END;
Outint(nr_record,5); Outint(nr_addpool,5);
Outint(nr_get,5); Outint(nr_lookup,5); Outint(nr_loct,5);
Outint(nr_locr,5); Outint(nr_load,5); Outint(nr_store,5);
Outint(nr_newpool,5);
Outimage;
END of closebase;
BOOLEAN PROCEDURE display_records;
BEGIN ! at ? or help display record types available;
INTEGER k;
outline("the following record types are defined:"); Outimage;
FOR k:=1 STEP 1 UNTIL rsptop DO
BEGIN
Setpos(5); outline(recordspec(k).rname);
Setpos(15); Outtext("attributes: ");
outline(recordspec(k).terms);
END;
END of display;
BOOLEAN PROCEDURE disp_types;
BEGIN ! display parameters and their types for record type r;
INTEGER k,adim;
outline("ATTRIBUTES AVAILABLE: "); Outimage;
adim:=current_spec.adim;
FOR k:= 1 STEP 1 UNTIL adim DO
BEGIN
Setpos(10);
Outtext(typtext(current_spec.atypes(k)));
Outchar(' ');
outline(current_spec.anames(k));
END;
END of disp_types;
PROCEDURE tabulate(r); REF (record) r;
!------------------------------------------------------
Type for record r either its key or all datafields
with names and values.
------------------------------------------------------;
IF nameonly THEN
outline(r.avalues(r.spec.keypos)) ELSE
BEGIN INTEGER max,k;
Outtext("------------ "); Outtext(r.spec.rname);
outline(" ---------------------------------------");
max:=r.spec.adim;
FOR k:=1 STEP 1 UNTIL max DO
BEGIN
Outtext(r.spec.anames(k));
IF Pos < 9 THEN Setpos(9); Outtext(" = ");
outline(r.avalues(k));
END;
END of tabulate;
!--------------------------------------------------------
Initiate data base file:
set default parameters and define internal structures,
open data base file asking the user for its name
and imagesize,
if it is an old database load all record-specifications.
--------------------------------------------------------;
defaultparms; d__file:-opendf; IF defined__f THEN loadspec;
INNER;
closebase;
END of class dbm;