(********************************************************** * * *********************************************************) PROGRAM DESCRIPTORBUILDER; (*version 0.0 - 2 Feb 1980*) (*Copyright 1980 Kenneth L. Bowles. All rights reserved. Permission is hereby granted to use this material for any non-commerical purpose*) USES DBUNIT; CONST WA0 = 0; FDNAMEOFFSET = 12; LASTFIELDDESCRIPTOR = 255; TYPE CHSET=SET OF CHAR; REFLIST=ARRAY[0..0] OF INTEGER; (*index 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; USECOUNT:BYTE; LAYOUT:BYTE; (*on a large system this could be declared TAG*) LASTFLDLINK:BYTE; (*points to name field*) 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; FDTYPE= PACKED RECORD CASE BOOLEAN OF TRUE: (S:STRING); FALSE: (R:FLDDESCRIPTOR) END; RDTYPE= PACKED RECORD CASE BOOLEAN OF TRUE: (S:STRING); FALSE: (R:RECDESCRIPTOR) END; GDTYPE= PACKED RECORD CASE BOOLEAN OF TRUE: (S:STRING); FALSE: (R:GRPDESCRIPTOR) END; STRINGPTR = ^STRING; TRIXPTR= RECORD CASE DBLEVELTYPE OF FIELDT: (F:FLDDESPTR); RECORDT:(R:RECDESPTR); GROUPT: (G:GRPDESPTR); NONET: (S:STRINGPTR) END (*TRIXPTR*); VAR DONE:BOOLEAN; ITEMLEVEL:DBLEVELTYPE; REMFILE:BOOLEAN; FOUT:INTERACTIVE; FUNCTION GETCOMMAND(S:STRING; OKSET:CHSET):CHAR; VAR CH:CHAR; BEGIN REPEAT WRITELN; WRITE(S); READ(CH); IF CH IN ['a'..'z'] THEN CH:=CHR(ORD(CH)-32); IF NOT (CH IN OKSET) THEN WRITE(' ORD(CH)=',ORD(CH)); UNTIL CH IN OKSET; WRITELN; GETCOMMAND:=CH; END (*GETCOMMAND*); PROCEDURE LOCATOR(GROUPNUM,RECNUM:INTEGER); VAR I:INTEGER; BEGIN DBSHOWERR('LOC#1', DBHOME(WA0)); DBSHOWERR('LOC#2', DBSEEK(WA0, GROUPNUM)); DBSHOWERR('LOC#3', DBDESCEND(WA0)); DBSHOWERR('LOC#4', DBSEEK(WA0, RECNUM)); END (*LOCATOR*); FUNCTION READI(S:STRING; X:INTEGER): INTEGER; VAR I:INTEGER; BEGIN WRITE(S,X, ' >'); READLN(I); IF EOF THEN BEGIN RESET(INPUT); READI:=X; WRITELN; END ELSE READI:=I; END (*READI*); PROCEDURE SHOWFLDTYPE(FLDTYPE:DBFIELDTYPES); BEGIN WRITE('FLD TYPE:'); IF NOT (FLDTYPE IN [BYTEF, GROUPF, INTEGERF, LONGINTF, STRINGF, SETF, PICF]) THEN WRITELN('***** ILLEGAL ****') ELSE CASE FLDTYPE OF BYTEF: WRITELN('BYTEF'); GROUPF: WRITELN('GROUPF'); INTEGERF: WRITELN('INTEGERF'); LONGINTF: WRITELN('LONGINTF'); SETF: WRITELN('SETF'); PICF: WRITELN('PICF'); TEXTF: WRITELN('TEXTF'); STRINGF: WRITELN('STRINGF') END (*CASE*); END (*SHOWFLDTYPE*); PROCEDURE SHOWFD(PS:STRING); VAR FD:FDTYPE; BEGIN FD.S:=PS; WITH FD.R DO BEGIN (*note: link value is one more than correct string length*) WRITELN('FIELD DESCRIPTOR:',NAME:(LENGTH(NAME)-1)); WRITELN('SWITCHES:', SWITCHES); WRITELN('MAX WIDTH:', MAXWIDTH); WRITELN('USECOUNT:', USECOUNT); SHOWFLDTYPE(FLDTYPE); WRITELN('FLDREF:', FLDREF); IF FLDREF = 0 THEN BEGIN WRITELN('ROW:', ROW); WRITELN('DATACOL:', DATACOL); WRITELN('LABELCOL:', LABELCOL); WRITELN('CONTROLBITS:', CONTROLBITS); END; END (*WITH*); END (*SHOWFD*); PROCEDURE BUILDFD; VAR NS:STRING; I,FLDNUM:INTEGER; CH:CHAR; FD:FDTYPE; BEGIN DBTYPECHECK:=FALSE; WRITELN; WRITE('FIELD NUMBER:'); READLN(FLDNUM); LOCATOR(3(*FD'S*), FLDNUM); CASE GETCOMMAND('BUILDFD: C(hange old field or N(ew field?', ['C','c','N','n']) OF 'C','c': BEGIN DBSHOWERR('BUILDFD-GET', DBGET(WA0)); FD.S:=DBMAIL.STRG; END; 'N','n': FILLCHAR(FD.S, 82, CHR(0)) END (*CASE*); WITH FD.R DO BEGIN WRITE('FIELD NAME:', NAME:LENGTH(NAME)-1, ' >'); READLN(NS); IF LENGTH(NS) > 0 THEN (*$R-*) BEGIN MOVELEFT(NS,NAME,LENGTH(NS)+1); NAME[0]:=CHR(LENGTH(NS)+1); OVERLINK:=LENGTH(NS)+SIZEOF(FLDDESCRIPTOR)-1; END ELSE WRITELN; (*$R+*) SWITCHES:=READI('SWITCH BYTE:',SWITCHES); MAXWIDTH:=READI('MAXIMUM WIDTH:', MAXWIDTH); USECOUNT:=0; SHOWFLDTYPE(FLDTYPE); WRITE(' G(ROUP R(EC S(TRING B(YTE I(NTEGER >'); REPEAT READ(CH); UNTIL (CH IN ['G', 'S', 'B', 'I']) OR EOF; WRITELN; IF EOF THEN RESET(INPUT) ELSE CASE CH OF 'B': FLDTYPE:=BYTEF; 'G': FLDTYPE:=GROUPF; 'I': FLDTYPE:=INTEGERF; 'S': FLDTYPE:=STRINGF END (*CASE*); IF FLDTYPE = GROUPF THEN FLDREF:=READI('DESCRIPTOR NUMBER:',FLDREF) ELSE FLDREF:=READI('Displayable (=0) or not (=1):', FLDREF); IF FLDTYPE <> GROUPF THEN BEGIN WRITE('Set Display Params? (Y/N)'); READ(CH); WRITELN; IF CH IN ['Y', 'y'] THEN BEGIN ROW:=READI('ROW:',ROW); DATACOL:=READI('DATACOL:', DATACOL); LABELCOL:=READI('LABELCOL:',LABELCOL); CONTROLBITS:=READI('CONTROLBITS:',CONTROLBITS); END; END; END (*WITH FD.R*); WRITELN; WRITE(' ACCEPTS; TRY AGAIN'); READ(KEYBOARD,CH); IF CH = CHR(3(*ETX*)) THEN WITH DBMAIL DO BEGIN STRG:=FD.S; DBMAILTYPE:=STRINGF; DBSHOWERR('BUILDFD', DBPUT(WA0)); END; END (*BUILDFD*); PROCEDURE SHOWRD(PS:STRING); VAR I,J,N:INTEGER; NS:STRING; RD:RDTYPE; BEGIN RD.S:=PS; NS:=RD.S; DELETE(NS,1,(RD.R.LASTFLDLINK+SIZEOF(RECDESCRIPTOR)-3)); WRITELN('RECORD DESCRIPTOR:',NS); WITH RD.R DO BEGIN WRITELN('SWITCHES:', SWITCHES); WRITELN('SIZE:', SIZE); WRITELN('FIRSTLINK - ITEM# ', FIRSTLITEMNUM); WRITELN('USECOUNT:', USECOUNT); WRITELN('LAYOUT:', LAYOUT); WRITELN('LASTFLDLINK:', LASTFLDLINK); END (*WITH*); I:=0; N:=0; J:=RD.R.LASTFLDLINK - 2; WHILE I < J DO BEGIN (*$R-*) WITH RD.R.FLDREF[N] DO WRITELN(' FLDREF(', N, ') - FDNUM:', FDNUM, ' OFFSET:', FLDOFFSET); I:=I+2; N:=N+1; (*$R+*) END; END (*SHOWRD*); PROCEDURE BUILDRD; VAR I,J,N,X,RECNUM:INTEGER; NAME:STRING; CH:CHAR; RD:RDTYPE; BEGIN REPEAT FILLCHAR(RD.S, 82, CHR(0)); WRITELN; WRITE('RECORD DEF NUMBER:'); READLN(RECNUM); LOCATOR(2(*RD'S*), RECNUM); WRITE('RECDEF NAME:'); READLN(NAME); WRITE('SWITCH BYTES:'); WITH RD.R DO BEGIN READLN(I); SWITCHES:=I; WRITE('SIZE:'); READLN(SIZE); WRITE('FIRSTLITEMNUM:'); READLN(I); FIRSTLITEMNUM:=I; USECOUNT:=0; WRITE('LAYOUT#:'); READLN(I); LAYOUT:=I; END (*WITH*); I:=8; J:=3; REPEAT N:=(I-8) DIV 2; WRITE('FLDREF #', N, ':'); READ(X); IF X >= 0 THEN (*$R-*) WITH RD.R.FLDREF[N] DO BEGIN FDNUM:=X; WRITE(' OFFSET #', N, ':'); READLN(X); FLDOFFSET:=X; (*$R+*) J:=J+2; I:=I+2; END; UNTIL X < 0; RD.R.OVERLINK:=2+I; RD.R.LASTFLDLINK:=J; (*leave 2 empty bytes*) RD.S:=CONCAT(RD.S,NAME); RD.S[2+I]:=CHR(LENGTH(NAME)+1); WRITELN; SHOWRD(RD.S); WRITE(' ACCEPTS; TRY AGAIN'); READ(KEYBOARD,CH); UNTIL CH = CHR(3(*ETX*)); WITH DBMAIL DO BEGIN STRG:=RD.S; DBMAILTYPE:=STRINGF; END; READ(CH); (*flush buffered char left by READ(X) of '-1'*) WRITELN; END (*BUILDRD*); PROCEDURE SHOWGD(PS:STRING); VAR I,J,N:INTEGER; A: ARRAY[0..0] OF INTEGER; NS:STRING; GD:GDTYPE; BEGIN GD.S:=PS; NS:=GD.S; DELETE(NS,1,(GD.R.RECLINK+SIZEOF(GRPDESCRIPTOR)-4)); WRITELN('GROUP DESCRIPTOR:',NS); WITH GD.R DO BEGIN WRITELN('SWITCHES:', SWITCHES); WRITELN('RECLINK:', RECLINK); END (*WITH*); I:=0; N:=0; J:=GD.R.RECLINK-2; WHILE I < J DO BEGIN (*$R-*) WRITELN(' RECNUM(', N, '):', GD.R.RECNUM[N]); (*$R+*) N:=N+1; I:=I+2; END; END (*SHOWGD*); PROCEDURE BUILDGD; VAR I,J,N,X,GRPNUM:INTEGER; NAME:STRING; CH:CHAR; GD:GDTYPE; BEGIN FILLCHAR(GD.S, 82, CHR(0)); REPEAT WRITELN; WRITE('GROUP DEF NUMBER:'); READLN(GRPNUM); LOCATOR(1(*GD'S*), GRPNUM); WRITE('GRPDEF NAME:'); READLN(NAME); WRITE('SWITCH BYTES:'); READLN(I); GD.R.SWITCHES:=I; I:=4; REPEAT N:=(I-4) DIV 2; WRITE('RECNUM #', N, ':'); READLN(X); IF X >= 0 THEN BEGIN (*$R-*) GD.R.RECNUM[N]:=X; (*$R+*) I:=I+2; END; UNTIL X < 0; GD.R.OVERLINK:=2+I; GD.R.RECLINK:=I; GD.S:=CONCAT(GD.S,NAME); GD.S[2+I]:=CHR(LENGTH(NAME)+1); WRITELN; SHOWGD(GD.S); WRITE(' ACCEPTS; TRY AGAIN'); READ(KEYBOARD,CH); UNTIL CH = CHR(3(*ETX*)); WITH DBMAIL DO BEGIN STRG:=GD.S; DBMAILTYPE:=STRINGF; END; END (*BUILDGD*); PROCEDURE BUILDLITERAL; VAR I:INTEGER; S:STRING; BEGIN CASE GETCOMMAND('LITERAL: I(NTEGER S(TRING ', ['I','S']) OF 'I': BEGIN WRITE('I>'); READLN(I); WITH DBMAIL DO BEGIN INT:=I; DBMAILTYPE:=INTEGERF; END; END; 'S': BEGIN WRITE('S>'); READLN(S); WITH DBMAIL DO BEGIN STRG:=S; DBMAILTYPE:=STRINGF; END; END END (*CASES*); END (*BUILDLITERAL*); PROCEDURE SHOWLITERAL; BEGIN WRITELN; CASE DBMAIL.DBMAILTYPE OF STRINGF: WRITELN('STRG: ', DBMAIL.STRG); INTEGERF: WRITELN('INT: ', DBMAIL.INT) (*LONGINTF: WRITELN('LINT: ', DBMAIL.LINT) *) END (*CASES*); END (*SHOWLITERAL*); PROCEDURE SHOWDATASTRUCTURE; VAR TP:TRIXPTR; GN:INTEGER; PROCEDURE GDOUT(TP:TRIXPTR; LEVEL,GN:INTEGER); FORWARD; PROCEDURE FDOUT(TP:TRIXPTR; LEVEL,FN:INTEGER); VAR NS:STRING; GP:TRIXPTR; BEGIN WITH TP.F^ DO BEGIN NS:=NAME; DELETE(NS,LENGTH(NS),1); (*note: link value is one more than correct string length*) WRITE(FOUT,'FLD(':(4+LEVEL), FN, '):',NS, ' ':17-LENGTH(NS)); WRITE(FOUT,' SW:', SWITCHES); WRITE(FOUT,' W:', MAXWIDTH); WRITE(FOUT,' T:'); IF NOT (FLDTYPE IN [BYTEF, GROUPF, INTEGERF, LONGINTF, STRINGF, SETF, PICF]) THEN WRITE(FOUT,'***** ILLEGAL ****') ELSE BEGIN CASE FLDTYPE OF BYTEF: WRITE(FOUT,'BYT'); GROUPF: WRITE(FOUT,'GRP'); INTEGERF: WRITE(FOUT,'INT'); LONGINTF: WRITE(FOUT,'LNI'); SETF: WRITE(FOUT,'SET'); PICF: WRITE(FOUT,'PIC'); TEXTF: WRITE(FOUT,'TXT'); STRINGF: WRITE(FOUT,'STR') END (*CASE*); IF FLDTYPE = GROUPF THEN BEGIN WRITELN(FOUT); DBGETDESCRIPTORNUM(GROUPT, FLDREF, GP.F); IF GP.F <> NIL THEN GDOUT(GP, LEVEL+2, FLDREF); END ELSE BEGIN IF FLDREF = 0 THEN WRITE(FOUT, ' ROW=', ROW, ' LCOL=', LABELCOL, ' DCOL=', DATACOL); WRITELN(FOUT); END; END (*FLDTYPE OK*); END (*WITH TP.F^*); END (*FDOUT*); PROCEDURE RDOUT(TP:TRIXPTR; LEVEL,RN:INTEGER); VAR I,J,N:INTEGER; NS:STRING; FP:TRIXPTR; BEGIN NS:=TP.S^; DELETE(NS,1,(TP.R^.LASTFLDLINK+SIZEOF(RECDESCRIPTOR)-3)); (*correct for link to string length*) DELETE(NS, LENGTH(NS),1); WRITE(FOUT,'REC(':(4+LEVEL), RN, '):',NS, ' ':18-LENGTH(NS)); WITH TP.R^ DO BEGIN WRITE(FOUT,' SW:', SWITCHES); WRITELN(FOUT,' SIZE:', SIZE); END (*WITH*); I:=0; N:=0; J:=TP.R^.LASTFLDLINK - 4; WHILE I < J DO BEGIN (*$R-*) WITH TP.R^.FLDREF[N] DO BEGIN DBGETDESCRIPTOR(FIELDT, FDNUM, FP.F); (*$R+*) IF FP.F <> NIL THEN FDOUT(FP, LEVEL+2, FDNUM); END; I:=I+2; N:=N+1; END; END (*RDOUT*); PROCEDURE GDOUT(*TP:TRIXPTR; LEVEL,GN:INTEGER*); VAR I,J,N:INTEGER; NS:STRING; RP:TRIXPTR; BEGIN NS:=TP.S^; DELETE(NS,1,(TP.G^.RECLINK+SIZEOF(GRPDESCRIPTOR)-4)); (*correct for link to string length*) DELETE(NS, LENGTH(NS),1); WRITE(FOUT,'GRP(':(4+LEVEL), GN, '):',NS, ' ':18-LENGTH(NS)); WITH TP.G^ DO BEGIN WRITELN(FOUT,' SW:', SWITCHES); I:=0; N:=0; J:=RECLINK-4; WHILE I < J DO BEGIN (*$R-*) DBGETDESCRIPTOR(RECORDT, RECNUM[N], RP.F); (*$R+*) IF RP.F <> NIL THEN RDOUT(RP,LEVEL+2, RECNUM[N]); N:=N+1; I:=I+2; END; END (*WITH TP.G^*); END (*GDOUT*); BEGIN (*SHOWDATASTRUCTURE*) WRITELN(FOUT); GN:=0; DBGETDESCRIPTOR(GROUPT, GN, TP.F); WHILE TP.F <> NIL DO BEGIN GDOUT(TP,0, GN); WRITELN(FOUT); GN:=GN+1; DBGETDESCRIPTOR(GROUPT, GN, TP.F); END; END (*SHOWDATASTRUCTURE*); PROCEDURE SHOWITEMINFO; VAR ITEMNUM,OFFSET,DESCRIPTORNUM:INTEGER; NAME:STRING; BEGIN WRITELN; DBITEMINFO(WA0,ITEMLEVEL,ITEMNUM,OFFSET,DESCRIPTORNUM,NAME); WRITE('LEVEL='); CASE ITEMLEVEL OF GROUPT: WRITE('GROUPT'); RECORDT:WRITE('RECORDT'); FIELDT: WRITE('FIELDT'); NONET: WRITE('NONET') END (*CASES*); WRITELN(' ITEM#', ITEMNUM, ' OFFSET=', OFFSET, ' DESCRIP#', DESCRIPTORNUM, ' NAME=', NAME); END (*SHOWITEMINFO*); PROCEDURE NEWEMPTY; VAR CH:CHAR; TAG:INTEGER; BEGIN SHOWITEMINFO; WRITE('Make new item? (Y/N)'); READ(CH); WRITELN; IF CH IN ['Y','y'] THEN BEGIN CASE ITEMLEVEL OF GROUPT: CASE GETCOMMAND('new embedded R(ecord or new G(roup?', ['G','R']) OF 'G': BEGIN WRITE('TAG VALUE:'); READLN(TAG); DBSHOWERR('NEWEMPTY-GROUPT', DBEMPTYITEM(WA0,GROUPT,TAG)); END; 'R': DBSHOWERR('NEWEMPTY-REC', DBEMPTYITEM(WA0,RECORDT,TAG)) END (*CASE GROUPT*); RECORDT,FIELDT: DBSHOWERR('NEWEMPTY', DBEMPTYITEM(WA0,ITEMLEVEL,TAG)); NONET: BEGIN (*do nothing*) END END (*CASE ITEMLEVEL*); END (*IF CH*); END (*NEWEMPTY*); PROCEDURE TRANSFERPRIMITIVES; BEGIN CASE GETCOMMAND('XFER: E(MPTY G(ET P(UT R(EMOUT T(YPECHECK Q(UIT ', ['E', 'G', 'P', 'R', 'T', 'Q']) OF 'E': NEWEMPTY; 'P': DBSHOWERR('XFER-PUT', DBPUT(WA0)); 'G': DBSHOWERR('XFER-GET', DBGET(WA0)); 'R': BEGIN REMFILE:=NOT REMFILE; CLOSE(FOUT); IF REMFILE THEN BEGIN RESET(FOUT, 'CONSOLE:'); WRITELN('Output now to CONSOLE:'); END ELSE BEGIN RESET(FOUT, 'REMOUT:'); WRITELN('Output now to REMOUT:'); END; END; 'T': BEGIN DBTYPECHECK:=NOT DBTYPECHECK; WRITE('DBTYPECHECK NOW '); IF DBTYPECHECK THEN WRITELN('TRUE') ELSE WRITELN('FALSE'); END; 'Q': BEGIN (*do nothing*) END END (*CASES*); END (*TRANSFERPRIMITIVES*); PROCEDURE FILEHANDLER; CONST FNUM=0; PGZERO=0; EMPTYSTRING=''; VAR TITLE:STRING; CH:CHAR; DUMMY:INTEGER; PROCEDURE GETTITLE; BEGIN WRITE('FILE TITLE:'); READLN(TITLE); END (*GETTITLE*); BEGIN (*FILEHANDLER*) CASE GETCOMMAND( 'FILE: N(EWFILE O(PEN I(NIT-GROUPS C(LOSE R(EMOVE G(ET P(UT Q(UIT', ['C','G','I','N','O','P','R','Q']) OF 'C': DBSHOWERR('FILE(C)', DBFCLOSE(FNUM)); 'G': DBSHOWERR('FILE(G)', DBGETPAGE(FNUM,WA0,PGZERO)); 'I': DBSHOWERR('FILE(I)', DBGROUPINIT(FNUM,DUMMY,'ALL')); 'N': BEGIN WRITE('NEW '); GETTITLE; DBSHOWERR('FILE(N)', DBFCREATE(FNUM,WA0,EMPTYSTRING,TITLE)); END; 'O': BEGIN WRITE('OLD '); GETTITLE; DBSHOWERR('FILE(O)', DBFOPEN(FNUM, TITLE)); END; 'P': DBSHOWERR('FILE(P)', DBPUTPAGE(FNUM, WA0, PGZERO)); 'R': BEGIN WRITE('REMOVE OLD FILE (Y/N)?'); READ(CH); IF CH = 'Y' THEN DBSHOWERR('FILE(R)', DBFREMOVE(FNUM)); END; 'Q': BEGIN (*DO NOTHING*); END END (*CASE*); END (*FILEHANDLER*); PROCEDURE TESTFINDREC; VAR FN,RN:INTEGER; FOUND:BOOLEAN; KEY:STRING; BEGIN WRITELN('TEST DBFINDREC PROCEDURE'); WRITE('FIELDNUM:'); READLN(FN); WRITE('KEY(STRING):'); READLN(KEY); DBSHOWERR('TESTFINDREC', DBFINDREC(WA0, ASCENDING, FN, KEY, RN, FOUND)); IF FOUND THEN WRITE(' FOUND RECORD') ELSE WRITE(' COULDN''T FIND KEY'); WRITELN(' RECNUM=', RN); WRITELN; END (*TESTFINDREC*); PROCEDURE MOVER; VAR N,G,R:INTEGER; BEGIN CASE GETCOMMAND( 'MOVE: B(EGIN-LEVEL F(IND H(OME N(EXT T(AIL S(EEK D(ESCEND L(OCATE Q(UIT', ['B','F','H','N','S','T','D','L','Q']) OF 'B': DBSHOWERR('MOVE-HEAD', DBHEAD(WA0)); 'F': TESTFINDREC; 'H': DBSHOWERR('MOVE-HOME', DBHOME(WA0)); 'N': DBSHOWERR('MOVE-NEXT', DBNEXT(WA0)); 'T': DBSHOWERR('MOVE-TAIL', DBTAIL(WA0)); 'S': BEGIN WRITELN; WRITE('ITEM NUMBER:'); READLN(N); DBSHOWERR('MOVE-SEEK', DBSEEK(WA0, N)); END; 'D': DBSHOWERR('MOVE-DESCEND', DBDESCEND(WA0)); 'L': BEGIN WRITELN; WRITE('GROUP:'); READLN(G); WRITE(' RECORD:'); READLN(R); LOCATOR(G,R); END; 'Q': BEGIN (*DO NOTHING*) END END (*CASES*); END (*MOVER*); PROCEDURE SETTRACESITES; VAR I:INTEGER; BEGIN WRITELN('ENTER TRACE SITE NUMBERS ( Terminates input list)'); REPEAT WRITE('>'); READLN(I); IF NOT EOF THEN IF (I>=0) AND (I <= 100) THEN DBTRACESET := DBTRACESET + [I]; UNTIL EOF; RESET(INPUT); END (*SETTRACESITES*); PROCEDURE INIT; VAR I:INTEGER; BEGIN DBINITIALIZE; WRITELN('DESCRIPTOR BUILDER INITIALIZING'); DBTYPECHECK:=FALSE; SETTRACESITES; (*put 5 empty groups in wa0*) FOR I:=0 TO 4 DO DBSHOWERR('INIT#2', DBEMPTYITEM(WA0,GROUPT,0)); (*put one empty linked record in each group, thus permitting traversal operations to function*) FOR I:=1 TO 4 DO BEGIN DBSHOWERR('INIT-HOME',DBHOME(WA0)); DBSHOWERR('INIT-SEEK',DBSEEK(WA0,I)); DBSHOWERR('INIT#4', DBEMPTYITEM(WA0, RECORDT,0)); END; DONE:=FALSE; REMFILE:=FALSE; RESET(FOUT, 'CONSOLE:'); END (*INIT*); BEGIN (*MAIN PROGRAM*) INIT; REPEAT CASE GETCOMMAND( 'B(UILD X(FER D(ISPLAY F(ILE M(OVE S(TRUCT W(RITE Q(UIT', ['B','X','D','F','M','S','T','W','Q']) OF 'B': CASE GETCOMMAND('BUILD: G(ROUP R(ECORD F(IELD L(ITERAL', ['G','R','F','L']) OF 'F': BUILDFD; 'G': BUILDGD; 'L': BUILDLITERAL; 'R': BUILDRD END (*CASE*); 'X': TRANSFERPRIMITIVES; 'D': CASE GETCOMMAND('DISPLAY: G(ROUP R(ECORD F(IELD L(ITERAL', ['G','R','F','L']) OF 'F': SHOWFD(DBMAIL.STRG); 'G': SHOWGD(DBMAIL.STRG); 'L': SHOWLITERAL; 'R': SHOWRD(DBMAIL.STRG) END (*CASE*); 'F': FILEHANDLER; 'M': MOVER; 'S': SHOWDATASTRUCTURE; 'T': SETTRACESITES; 'W': DBSHOWERR('WRITEFIELD', DBWRITEFIELD(OUTPUT,WA0)); 'Q': DONE:=TRUE END (*CASE*); UNTIL DONE; END.