Google
 

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;