(* L #5:DBUNIT.LST.TEXT*) {make sure you leave plenty of room for the listing}
(*$S+*)
UNIT DBUNIT; (*version 1.2 - 5 Feb, 1980*)
  (*Copyright 1980 Kenneth L. Bowles. All rights reserved. Permission
    is hereby granted to use this material for any non-commercial 
    purpose*)
INTERFACE
CONST
  LASTWRKINDEX=20;
  LONGINTSIZE=14;
  SETSIZE=47;
  NAMESTRSIZE=30;
  LASTFILENUM=4;
  
TYPE
  BYTE=0..255;
  DBWRKINDEX=0..LASTWRKINDEX;
  DBERRTYPE=0..100; (*not a scalar to conserve symbols*)
  DBFILENUM=0..LASTFILENUM;
  DBFIELDTYPES=(GROUPF, STRINGF, BYTEF, INTEGERF, LONGINTF,
                ADDRCOUPLEF, SETF, PICF, TEXTF);
                
  DBLEVELTYPE=(NONET, GROUPT, RECORDT, FIELDT);
  DBFINDRULE=(ASCENDING, DESCENDING, RANDOM);
  
  FILETYPE=FILE; (*compiler won't acccept 'file' as parameter type*)
  
  FLDDESCRIPTOR=
    PACKED RECORD
      OVERLINK:BYTE;
      SWITCHES:BYTE; (*bit 0 = tagged; bit 1 = fixedwidth *)
      MAXWIDTH:INTEGER;
      USECOUNT:BYTE;
      FLDTYPE:DBFIELDTYPES;
      FLDREF:INTEGER; (*points to descriptor of FLDTYPE; =0 IF NOT GROUPF*)
      (*following may get moved to Layout later*)
      ROW:BYTE;
      DATACOL:BYTE;
      LABELCOL:BYTE;
      CONTROLBITS:BYTE;
      NAME:STRING[1]  (*generally will be expanded out of rangechecking*)
    END;
  FLDDESPTR=^FLDDESCRIPTOR;
  

VAR
  DBTYPECHECK:BOOLEAN; (*if false can't use fixed length records*)
  DEBUGGING:BOOLEAN;
  F0,F1,F2,F3,F4:FILETYPE;
  
  DBMAIL:
    RECORD CASE DBMAILTYPE: DBFIELDTYPES OF
      GROUPF: ( ); (*TO BE DEFINED*)
      STRINGF: (STRG:STRING[255]);
      BYTEF: (BYT:BYTE);
      INTEGERF: (INT:INTEGER);
      LONGINTF: (LINT:INTEGER[LONGINTSIZE]);
      ADDRCOUPLE:(PGE:INTEGER;
                  GRP:INTEGER;
                  REC:INTEGER);
      SETF: (SETT:PACKED ARRAY[0..SETSIZE] OF BOOLEAN);
      PICF: ( ); (* PICTURES TO BE DEFINED *)
      TEXTF: (TXT: PACKED ARRAY[0..255] OF CHAR)
    END (*DBMAIL*);
    
  DBIORESULT:INTEGER;
  DBTRACESET:SET OF DBERRTYPE;
    
(*TRAVERSAL PRIMITIVES*)
  FUNCTION DBHOME(WI:DBWRKINDEX):DBERRTYPE;
  FUNCTION DBHEAD(WI:DBWRKINDEX):DBERRTYPE;
  FUNCTION DBNEXT(WI:DBWRKINDEX):DBERRTYPE;
  FUNCTION DBTAIL(WI:DBWRKINDEX):DBERRTYPE;
  FUNCTION DBSEEK(WI:DBWRKINDEX; WHICHITEM:INTEGER):DBERRTYPE;
  FUNCTION DBDESCEND(WI:DBWRKINDEX):DBERRTYPE;
  FUNCTION DBASCEND(WI:DBWRKINDEX):DBERRTYPE;
  FUNCTION DBFINDREC(WI:DBWRKINDEX; RULE:DBFINDRULE; FIELDNUM:INTEGER;
                     KEY:STRING; VAR RECNUM:INTEGER;
                     VAR FOUND:BOOLEAN):DBERRTYPE;
  
(*DATA TRANSFER PRIMITIVES*)
  FUNCTION DBCOPY(SOURCE,DESTINATION:DBWRKINDEX):DBERRTYPE;
  FUNCTION DBEMPTYITEM(DESTINATION:DBWRKINDEX; LVL:DBLEVELTYPE;
                                               TAG:INTEGER):DBERRTYPE;
  FUNCTION DBDELETE(DESTINATION:DBWRKINDEX):DBERRTYPE;
  FUNCTION DBBLANK(DESTINATION:DBWRKINDEX):DBERRTYPE;
  FUNCTION DBREPLACE(SOURCE,DESTINATION:DBWRKINDEX):DBERRTYPE;
  FUNCTION DBRESERVE(DESTINATION:DBWRKINDEX):DBERRTYPE;
  FUNCTION DBGET(SOURCE:DBWRKINDEX):DBERRTYPE;
  FUNCTION DBPUT(DESTINATION:DBWRKINDEX):DBERRTYPE;

(*SUPPORT PRIMITIVES*)
  FUNCTION DBWRITEFIELD(VAR FID:TEXT; SOURCE:DBWRKINDEX):DBERRTYPE;
  PROCEDURE DBGETDESCRIPTOR(LEVEL:DBLEVELTYPE; 
                            DESCRIPTORNUM:INTEGER;
                            VAR PTR:FLDDESPTR);
  FUNCTION DBTAG(NAME:STRING; SOURCE:DBWRKINDEX; VAR ITEMNUM:INTEGER):DBERRTYPE;
  
(*WORKAREA PRIMITIVES*)
  FUNCTION DBWRKOPEN(WI:DBWRKINDEX; SIZE:INTEGER):DBERRTYPE;
  FUNCTION DBWRKCLOSE(WI:DBWRKINDEX):DBERRTYPE;
  PROCEDURE ZEROWORKAREA(WI:DBWRKINDEX);

(*FILE PRIMITIVES*)
  FUNCTION DBFOPEN(FNUM:DBFILENUM; TITLE:STRING):DBERRTYPE;
  FUNCTION DBFCLOSE(FNUM:DBFILENUM):DBERRTYPE;
  FUNCTION DBFCREATE(FNUM:DBFILENUM; WASCRATCH:DBWRKINDEX;
                                     SPEXTITLE,NEWTITLE:STRING):DBERRTYPE;
  FUNCTION DBFREMOVE(FNUM:DBFILENUM):DBERRTYPE;
  FUNCTION DBGETPAGE(FNUM:DBFILENUM; DESTINATION:DBWRKINDEX;
                                     PAGENUM:INTEGER):DBERRTYPE;
  FUNCTION DBPUTPAGE(FNUM:DBFILENUM; SOURCE:DBWRKINDEX;
                                     PAGENUM:INTEGER):DBERRTYPE;

(*DESCRIPTOR INITIALIZING PRIMITIVES*)
  FUNCTION DBGROUPINIT(FNUM:DBFILENUM; VAR GROUPNUM:INTEGER;
                                              GROUPNAME:STRING):DBERRTYPE;
  FUNCTION DBGROUPRELEASE(GROUPNUM:INTEGER):DBERRTYPE;
  
(*INITIALIZATION*)
  PROCEDURE DBINITIALIZE;
  
(*ORDERLY TERMINATION*)
  FUNCTION DBCLOSEDOWN:DBERRTYPE;
  
(*ERROR REPORTING AND DIAGNOSTICS*)
  PROCEDURE DBSHOWERROR(S:STRING; ERRNUM:DBERRTYPE);
  PROCEDURE DBITEMINFO(WI:DBWRKINDEX; VAR LEVEL:DBLEVELTYPE;
           VAR ITEMNUM,OFFSET,DESCRIPTORNUM:INTEGER; VAR NAME:STRING);
  
(**************************************************************)
IMPLEMENTATION
CONST
  PAGELASTBYTE=4095;
  LASTSPECIALGROUP=6;
  LASTWRKSTACKSLOT=9;
  LASTGROUPDESCRIPTOR=255;
  LASTRECDESCRIPTOR=255;
  LASTFIELDDESCRIPTOR=255;
  LINKESCAPE=240;
  DBNUL=0;
  ONEITEMRECLINK=6;
  
TYPE
  PAGEPTR=0..PAGELASTBYTE;
  PAGETYPE=PACKED ARRAY[PAGEPTR] OF BYTE;
  
  (*work area information block - WIB *)
  WIBENTRY=
    RECORD
      OFFSET:PAGEPTR;
      LEVEL:DBLEVELTYPE;
      DESCRIPTORNUM:INTEGER;
      ITEMNUM:INTEGER;
    END;
  TOSRANGE=0..LASTWRKSTACKSLOT;
  WIBTYPE=ARRAY[TOSRANGE] OF WIBENTRY;
  WIBPTR=^WIBTYPE;
  
  (*following are dummy types used for heap allocation of workareas*)
  WATYPE=PACKED ARRAY[0..63] OF BYTE; (* WA will be multiple of these*)
  WAPTR=^WATYPE;
  ONEWORDPTR=^INTEGER;
  REFLIST=ARRAY[0..0] OF INTEGER; (*index with range checking off*)
  
  (*fixed layout parts of descriptors*)
  GRPDESCRIPTOR=
    PACKED RECORD
      OVERLINK:BYTE; (*descriptor longer than 240 bytes not allowed*)
      SWITCHES:BYTE; (*packed array gets allocated in whole words*)
                     (*bit 0 = tagged; bit 1 = linked *)
      RECLINK:BYTE;
      FILLER:BYTE;
      RECNUM:REFLIST;
      (*expand here with additional recnum's*)
    END;
  GRPDESPTR=^GRPDESCRIPTOR;
  
  RECDESCRIPTOR=
    PACKED RECORD
      OVERLINK:BYTE;
      SWITCHES:BYTE; (*bit 0 = tagged; bit 1 = fixed width; bit 2 = sparse *)
      SIZE:INTEGER;
      FIRSTLITEMNUM:BYTE; (*set to 1 more than last fixed itemnumber if
                            there are only fixed fields in the record*)
      USECOUNT:BYTE;
      LAYOUT:BYTE; (*on a large system this could be declared TAG*)
      LASTFLDLINK:BYTE; (*points to name field, indirect upper bound of
                            FLDREF array*)
      FLDREF:ARRAY [0..0] OF
               PACKED RECORD
                 FDNUM: 0..LASTFIELDDESCRIPTOR;
                 FLDOFFSET:BYTE; (*for fixed size fields; =0 for linked*)
               END;
      (*expand here with additional fldref's*)
    END;
  RECDESPTR=^RECDESCRIPTOR;

  CRACKSWTYPE=  (*for accessing individual switch control bits*)
    PACKED RECORD
      CASE BOOLEAN OF
        TRUE:(BL:BYTE; BH:BYTE);
        FALSE:(A:PACKED ARRAY[0..15] OF BOOLEAN);
      END (*CRACKSWTYPE*);

VAR
  HEAPMARKER:ONEWORDPTR;
  OPENFILES: PACKED ARRAY[0..LASTFILENUM] OF BOOLEAN;
  
  (*page numbers of fixed numbered groups at beginning of file*)
  SPECIALGROUPPAGE: ARRAY[0..LASTSPECIALGROUP] OF INTEGER;
  
  (*all access to workareas flows via WRKTABLE*)
  WRKTABLE: ARRAY[DBWRKINDEX] OF
    RECORD
      TOS: TOSRANGE; (*top of stack*)
      WIB: WIBPTR; (*points to stack of offsets in WIB; NIL if none allocated*)
      WSIZE: INTEGER; (*size of Workarea in bytes*)
      SPACEINUSE: INTEGER; (*initially 0*)
      WA: WAPTR  (*the workarea itself*)
    END;
      
  (*all access to on-line descriptors is via these arrays*)
  ACTIVEGROUPS: ARRAY[0..LASTGROUPDESCRIPTOR] OF GRPDESPTR;
  ACTIVERECORDS: ARRAY[0..LASTRECDESCRIPTOR] OF RECDESPTR;
  ACTIVEFIELDS: ARRAY[0..LASTFIELDDESCRIPTOR] OF FLDDESPTR;
  
  (*Lower and Upper bound for tracing*)
  TRACELB,TRACEUB:INTEGER;