home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / sigm / vols000 / vol025 / dbunit.2 < prev    next >
Text File  |  1984-04-29  |  19KB  |  646 lines
  1. PROCEDURE SETTRACESITES;
  2. CONST RET=13;
  3. VAR I:INTEGER;
  4.   CH:CHAR;
  5. BEGIN
  6.   WRITELN;
  7.   WRITELN('Enter trace site numbers (-1 terminates)');
  8.   REPEAT
  9.     WRITE('>');
  10.     READLN(I);
  11.     IF (I>=0) AND (I<=100) THEN
  12.       BEGIN
  13.         IF I IN DBTRACESET THEN WRITE(' ON')
  14.                            ELSE WRITE(' OFF');
  15.         WRITE('   S(et or R(eset ?');
  16.         REPEAT
  17.           READ(CH);
  18.         UNTIL CH IN ['R','S'];
  19.         IF CH='S' THEN
  20.           DBTRACESET:=DBTRACESET+[I]
  21.         ELSE
  22.           DBTRACESET:=DBTRACESET-[I];
  23.       END;
  24.     WRITELN;
  25.   UNTIL I<0;
  26.   REPEAT
  27.     WRITE('L(ower Bound=', TRACELB, '  U(pper Bound=', TRACEUB, '  <RET>');
  28.     READ(CH);
  29.     IF EOLN THEN CH:=CHR(RET) ELSE WRITELN;
  30.     IF CH = 'L' THEN
  31.       BEGIN
  32.         WRITE('  LB:');
  33.         READLN(TRACELB);
  34.       END
  35.     ELSE
  36.       IF CH = 'U' THEN
  37.         BEGIN
  38.           WRITE('  UB:');
  39.           READLN(TRACEUB);
  40.         END;
  41.   UNTIL CH = CHR(RET);
  42. END (*SETTRACESITES*);
  43.   
  44. PROCEDURE TRACEWA(TRACENUM:INTEGER; WI:DBWRKINDEX);
  45. VAR I,L,P:INTEGER;
  46.   DONE:BOOLEAN;
  47.   S:STRING[10];
  48. BEGIN
  49.   DONE:=FALSE;
  50.   WHILE (TRACENUM IN DBTRACESET) AND (NOT DONE) DO
  51.     BEGIN
  52.       WRITELN;
  53.       WITH WRKTABLE[WI] DO
  54.         BEGIN
  55.           WRITELN('TRACE # ', TRACENUM, '  WA:', WI,
  56.                   '  TOS:', TOS,
  57.                   '  WSIZE:', WSIZE,
  58.                   '  SPACEINUSE:', SPACEINUSE);
  59.           IF WIB = NIL THEN
  60.             WRITELN('  WIB = NIL ****')
  61.           ELSE
  62.             FOR L:=0 TO TOS DO
  63.               WITH WIB^[L] DO
  64.                 BEGIN
  65.                   WRITE('  L:', L, ':  OFFSET:', OFFSET, '  LEVEL:');
  66.                   CASE LEVEL OF
  67.                     GROUPT: WRITE('GROUP');
  68.                     RECORDT: WRITE('RECORD');
  69.                     FIELDT: WRITE('FIELD');
  70.                     NONET: WRITE('NONE')
  71.                   END (*CASE*);
  72.                   WRITELN('  DESCR#:', DESCRIPTORNUM);
  73. (*$L #5:DBUXXX.LST.TEXT*)
  74.                   
  75.                 END (*WITH WIB*);
  76.           P:=TRACELB;
  77.           IF WA = NIL THEN
  78.             WRITELN('    WA = NIL')
  79.           ELSE
  80.             WHILE P <= TRACEUB DO
  81.               BEGIN
  82.                 WRITE('    ', P:3, ':');
  83.                 FOR I:=0 TO 9 DO
  84.                   BEGIN
  85. (*$R-*)
  86.                     WRITE(WA^[P]:4);
  87. (*$R+*)
  88.                     P:=P+1;
  89.                   END;
  90.                 WRITELN;
  91.               END;
  92.           WRITELN('<RET> CONTINUES; "D<RET>" TOGGLES DEBUGGING');
  93.           WRITE(' "T<RET>" TO CHANGE TRACE SITES:');
  94.           READLN(S);
  95.           DONE:=TRUE;
  96.           IF LENGTH(S) > 0 THEN
  97.             IF S[1] = 'T' THEN
  98.               BEGIN
  99.                 SETTRACESITES;
  100.                 WRITE('<RET> CONTINUES; R<RET> RE-DISPLAYS');
  101.                 READLN(S);
  102.                 IF LENGTH(S) > 0 THEN
  103.                   DONE:=(S[1] <> 'R');
  104.               END
  105.             ELSE
  106.               IF S[1] = 'D' THEN
  107.                 DEBUGGING:=NOT DEBUGGING;
  108.         END (*WITH WRKTABLE*);
  109.     END (*DEBUGGING*);
  110. END (*TRACEWA*);
  111.  
  112. PROCEDURE DBSHOWERROR(*S:STRING; ERRNUM: DBERRTYPE*);
  113. CONST
  114.   RET=13;
  115.   CAN=24;
  116.   ESC=27;
  117. VAR CH:CHAR;
  118. BEGIN
  119.   IF (ERRNUM<>0) OR DEBUGGING THEN
  120.     (*temporary substitute for display of actual message*)
  121.     BEGIN
  122.       WRITELN;
  123.       WRITELN('DBERROR # ', ERRNUM, ' IN ', S);
  124.       WRITELN(' <RET> CONTINUES, <ESC> ABORTS, <CAN> TERMINATES');
  125.       WRITELN(' "T" TO CHANGE TRACE SITES');
  126.       REPEAT
  127.         READ(CH);
  128.         IF EOLN THEN CH:=CHR(RET);
  129.       UNTIL CH IN [CHR(RET), CHR(CAN), CHR(ESC), 'T'];
  130.       IF CH = CHR(CAN) THEN
  131.         EXIT(PROGRAM);
  132.       IF CH = CHR(ESC) THEN
  133.         HALT;
  134.       IF CH = 'T' THEN SETTRACESITES;
  135.     END;
  136. END (*DBSHOWERROR*);
  137.  
  138. PROCEDURE DBITEMINFO(*WI:DBWRKINDEX; VAR LEVEL:DBLEVELTYPE;
  139.             VAR ITEMNUM,OFFSET,DESCRIPTORNUM:INTEGER; VAR NAME:STRING*);
  140. TYPE
  141.   TRICKPTR =
  142.     RECORD CASE BOOLEAN OF
  143.       TRUE: (R:RECDESPTR);
  144.       FALSE:(G:GRPDESPTR)
  145.     END;
  146. VAR FP:FLDDESPTR;
  147.   TP:TRICKPTR;
  148.   NILMSG:STRING[25];
  149.   DPTR:INTEGER;
  150.   PAB:PACKED ARRAY[0..255] OF BYTE;
  151.   
  152.   PROCEDURE EXTRACTNAME(TP:TRICKPTR; DPTR:INTEGER);
  153.   BEGIN
  154.     (*get the name field length into PAB[DPTR]*)
  155.     MOVELEFT(TP.R^, PAB, DPTR+1);
  156.     (*this time transfer the name*)
  157.     MOVELEFT(TP.R^, PAB, DPTR+PAB[DPTR]);
  158.     MOVELEFT(PAB[DPTR], NAME, PAB[DPTR]);
  159.     (*convert to string*)
  160.     DELETE(NAME, LENGTH(NAME), 1);
  161.   END (*EXTRACTNAME*);
  162.   
  163. BEGIN (*DBITEMINFO*)
  164.   WITH WRKTABLE[WI] DO
  165.     BEGIN
  166.       LEVEL:=WIB^[TOS].LEVEL;
  167.       ITEMNUM:=WIB^[TOS].ITEMNUM;
  168.       OFFSET:=WIB^[TOS].OFFSET;
  169.       DESCRIPTORNUM:=WIB^[TOS].DESCRIPTORNUM;
  170.       NILMSG:='NIL Descriptor Pointer';
  171.       WITH WIB^[TOS] DO
  172.         BEGIN
  173.           IF (DESCRIPTORNUM < 0) THEN
  174.             NAME:='Uninitialized Descriptor Number'
  175.           ELSE
  176.             CASE LEVEL OF
  177.               FIELDT:
  178.                 BEGIN
  179.                   FP:=ACTIVEFIELDS[DESCRIPTORNUM];
  180.                   IF FP=NIL THEN
  181.                     NAME:=NILMSG
  182.                   ELSE
  183.                     NAME:=FP^.NAME;
  184.                 END (*FIELDT:*);
  185.               RECORDT:
  186.                 BEGIN
  187.                   TP.R:=ACTIVERECORDS[DESCRIPTORNUM];
  188.                   IF TP.R = NIL THEN
  189.                     NAME:=NILMSG
  190.                   ELSE
  191.                     BEGIN
  192.                       DPTR:=7 + TP.R^.LASTFLDLINK;
  193.                       EXTRACTNAME(TP,DPTR);
  194.                     END;
  195.                 END (*RECORDT:*);
  196.               GROUPT:
  197.                 BEGIN
  198.                   TP.G:=ACTIVEGROUPS[DESCRIPTORNUM];
  199.                   IF TP.G = NIL THEN
  200.                     NAME:=NILMSG
  201.                   ELSE
  202.                     BEGIN
  203.                       DPTR:=2 + TP.G^.RECLINK;
  204.                       EXTRACTNAME(TP,DPTR);
  205.                     END;
  206.                 END (*GROUPT:*)
  207.             END (*CASES*);
  208.         END (*WITH WIB^*);
  209.     END (*WITH*);
  210. END (*DBITEMINFO*);
  211.   
  212.   (*$L-*)
  213.   
  214. FUNCTION CHECKHEAP(SIZE:INTEGER):BOOLEAN;
  215. VAR MA:INTEGER;
  216. BEGIN
  217.   MA:=MEMAVAIL + MEMAVAIL;
  218.   CHECKHEAP:=(MA<0) (* i.e. more than 32767 *)
  219.               OR (MA>SIZE);
  220. END (*CHECKHEAP*);
  221.  
  222. FUNCTION MAX(X,Y:INTEGER):INTEGER;
  223. BEGIN
  224.   IF X>Y THEN MAX:=X ELSE MAX:=Y;
  225. END;
  226.  
  227. FUNCTION CHECKWORKAREA(WI:DBWRKINDEX; SIZE:INTEGER):DBERRTYPE;
  228. BEGIN
  229.   WITH WRKTABLE[WI] DO
  230.     IF (WA=NIL) OR (WIB=NIL) THEN
  231.       CHECKWORKAREA:=8 (*workarea not open*)
  232.     ELSE
  233.       IF WSIZE<>SIZE THEN
  234.         CHECKWORKAREA:=2
  235.       ELSE
  236.         CHECKWORKAREA:=0;
  237. END (*CHECKWORKAREA*);
  238.  
  239. FUNCTION HEAPALLOCATE(SIZE:PAGEPTR):DBERRTYPE;
  240. VAR
  241.     P1:ONEWORDPTR;
  242.     P64:WAPTR;
  243. BEGIN
  244.   IF CHECKHEAP(SIZE) THEN
  245.     BEGIN
  246.       WHILE SIZE >= 64 DO
  247.         BEGIN
  248.           NEW(P64);
  249.           SIZE:=SIZE-64;
  250.         END;
  251.       IF ODD(SIZE) THEN
  252.         SIZE:=SIZE+1;
  253.       WHILE SIZE>0 DO
  254.         BEGIN
  255.           NEW(P1);
  256.           SIZE:=SIZE-2;
  257.         END;
  258.       HEAPALLOCATE:=0;
  259.     END
  260.   ELSE
  261.     HEAPALLOCATE:=1; (*insufficient memory*)
  262. END (*HEAPALLOCATE*);
  263.  
  264. PROCEDURE ZEROWORKAREA(*WI:DBWRKINDEX*);
  265. (*unprotected -- call checkworkarea if in doubt*)
  266. VAR I:INTEGER;
  267. BEGIN
  268.   WITH WRKTABLE[WI] DO
  269.     BEGIN
  270.       FILLCHAR(WA^,WSIZE,CHR(0));
  271.       FOR I:=0  TO LASTWRKSTACKSLOT DO
  272.         WITH WIB^[I] DO
  273.           BEGIN
  274.             OFFSET:=0;
  275.             LEVEL:=NONET;
  276.             DESCRIPTORNUM:=-1;
  277.             ITEMNUM:=-1;
  278.           END;
  279.       WITH WIB^[0] DO
  280.         BEGIN
  281.           LEVEL:=GROUPT;
  282.           OFFSET:=0;
  283.           ITEMNUM:=0;
  284.         END;
  285.       SPACEINUSE:=0;
  286.       TOS:=0;
  287.     END (*WITH*);
  288. END (*ZEROWORKAREA*);
  289.  
  290. FUNCTION NEXTLEVEL(LVL:DBLEVELTYPE):DBLEVELTYPE;
  291. BEGIN
  292.   IF LVL=NONET THEN
  293.     NEXTLEVEL:=NONET
  294.   ELSE
  295.     IF LVL=FIELDT THEN
  296.       NEXTLEVEL:=GROUPT
  297.     ELSE
  298.       NEXTLEVEL:=SUCC(LVL);
  299. END (*NEXTLEVEL*);
  300.  
  301. FUNCTION MOVETAIL(DESTINATION:DBWRKINDEX; DELTA:INTEGER;
  302.                   OFFSET:PAGEPTR):DBERRTYPE;
  303. (*service routine for data transfer functions. shifts tail of workarea
  304.   after checking whether requested shift is legal *)
  305. BEGIN
  306.   MOVETAIL:=0;
  307.   WITH WRKTABLE[DESTINATION] DO
  308.     BEGIN
  309.       TRACEWA(2,DESTINATION);
  310.       IF (SPACEINUSE+DELTA) >= WSIZE THEN
  311.         MOVETAIL:=14 (*insufficient space*)
  312.       ELSE
  313.         IF (OFFSET+DELTA) < 0 THEN
  314.           MOVETAIL:=17 (*attempted negative offset*)
  315.         ELSE
  316.           BEGIN
  317. (*$R-*)
  318.             IF DELTA > 0 THEN
  319.               BEGIN
  320.                 MOVERIGHT(WA^[OFFSET], WA^[OFFSET+DELTA], SPACEINUSE-OFFSET);
  321.                 FILLCHAR(WA^[OFFSET],DELTA,CHR(0));
  322.               END
  323.             ELSE
  324.               IF DELTA < 0 THEN
  325.                 MOVELEFT(WA^[OFFSET], WA^[OFFSET+DELTA], SPACEINUSE-OFFSET);
  326.             SPACEINUSE:=SPACEINUSE+DELTA;
  327.             IF DELTA < 0 THEN
  328.               FILLCHAR(WA^[SPACEINUSE], -DELTA, CHR(0));
  329. (*$R+*)
  330.           END;
  331.       TRACEWA(3,DESTINATION);
  332.     END (*WITH*);
  333. END (*MOVETAIL*);
  334.  
  335. FUNCTION LINKVALUE(WA:WAPTR; OFFSET: PAGEPTR):PAGEPTR;
  336. VAR B1:BYTE;
  337. BEGIN
  338. (*$R-*)
  339.   B1:=WA^[OFFSET];
  340.   IF B1 < LINKESCAPE THEN
  341.     LINKVALUE:=B1
  342.   ELSE
  343.     LINKVALUE:=(B1-LINKESCAPE+1)*LINKESCAPE+WA^[OFFSET+1];
  344. (*$R+*)
  345. END (*LINKVALUE*);
  346.  
  347. PROCEDURE SAVEBIGLINK(DESTINATION:DBWRKINDEX; NEWLINK:INTEGER; OFFSET:PAGEPTR);
  348. BEGIN
  349.   WITH WRKTABLE[DESTINATION] DO
  350.     BEGIN
  351. (*$R-*)
  352.       IF NEWLINK < LINKESCAPE THEN
  353.         WA^[OFFSET]:=NEWLINK
  354.       ELSE
  355.         BEGIN
  356.           WA^[OFFSET]:=(NEWLINK DIV LINKESCAPE)+(LINKESCAPE-1);
  357.           WA^[OFFSET+1]:=(NEWLINK MOD LINKESCAPE);
  358.         END;
  359. (*$R+*)
  360.     END;
  361. END (*SAVEBIGLINK*);
  362.  
  363. FUNCTION LINKDELTA(DESTINATION:DBWRKINDEX; DELTA:INTEGER;
  364.                                            OFFSET:PAGEPTR):DBERRTYPE;
  365. (*add delta to the link at offset*)
  366. VAR B1,OLDLINK,NEWLINK:INTEGER;
  367.   CHOP:
  368.     PACKED RECORD CASE BOOLEAN OF
  369.       TRUE: (INT:INTEGER);
  370.       FALSE: (LB:BYTE; HB:BYTE)
  371.     END;
  372.  
  373. BEGIN
  374.   LINKDELTA:=0;
  375.   TRACEWA(4,DESTINATION);
  376.   WITH WRKTABLE[DESTINATION] DO
  377.     BEGIN
  378.       OLDLINK:=LINKVALUE(WA,OFFSET);
  379.       IF ((OFFSET+OLDLINK+DELTA) >= WSIZE) OR ((OLDLINK+DELTA) < 0) THEN
  380.         LINKDELTA:=16 (*out of range*)
  381.       ELSE
  382.         BEGIN
  383.           NEWLINK:=OLDLINK+DELTA;
  384.           IF NEWLINK > 4079 (* (256-LINKESCAPE)*256+(LINKESCAPE-1) *) THEN
  385.             LINKDELTA:=18 (* too large to be expressed as a link *)
  386.           ELSE
  387.             IF OLDLINK < LINKESCAPE THEN (* one byte *)
  388.               BEGIN
  389.                 IF NEWLINK < LINKESCAPE THEN (*also one byte*)
  390.   (*$R-*)
  391.                   WA^[OFFSET]:=NEWLINK
  392.                 ELSE
  393.                   BEGIN
  394.                     NEWLINK:=NEWLINK+1; (* one more byte for 2-byte link *)
  395.                     DBSHOWERR('LINKDELTA#1', MOVETAIL(DESTINATION,1,OFFSET));
  396.                     SAVEBIGLINK(DESTINATION,NEWLINK,OFFSET);
  397.                   END;
  398.               END (*OLDLINK < LINKESCAPE*)
  399.             ELSE
  400.               BEGIN (*OLDLINK >= LINKESCAPE i.e. 2 bytes*)
  401.                 IF (NEWLINK < LINKESCAPE) THEN
  402.                   BEGIN
  403.                     IF NEWLINK > 1 THEN
  404.                       NEWLINK:=NEWLINK-1; (*newlink 1-byte, oldlink was 2*)
  405.                                           (*however, cannot go < 1*)
  406.                     DBSHOWERR('LINKDELTA#2', MOVETAIL(DESTINATION,-1,
  407.                            OFFSET + 1(*avoid tromping on previous data*)));
  408.                     WA^[OFFSET]:=NEWLINK;
  409.   (*$R+*)
  410.                   END
  411.                 ELSE (*both old and new are 2 bytes*)
  412.                   SAVEBIGLINK(DESTINATION,NEWLINK,OFFSET);
  413.               END (*OLDLINK >= LINKESCAPE*);
  414.         END (* (OFFSET+DELTA) < WSIZE *);
  415.     END (*WITH WRKTABLE*);
  416.   TRACEWA(5,DESTINATION);
  417. END (*LINKDELTA*);
  418.  
  419. PROCEDURE FIXLINKS(DESTINATION:DBWRKINDEX; STACKCELL:TOSRANGE; DELTA:INTEGER);
  420. (*following a change in item contents, all enclosing levels must have 
  421.   links corrected*)
  422. VAR ISTACK:INTEGER;
  423. BEGIN
  424.   WITH WRKTABLE[DESTINATION] DO
  425.     FOR ISTACK:=STACKCELL DOWNTO 0 DO
  426.       WITH WIB^[ISTACK] DO
  427.         DBSHOWERR('FIXLINKS', LINKDELTA(DESTINATION,DELTA,OFFSET));
  428.   TRACEWA(16,DESTINATION);
  429. END (*FIXLINKS*);
  430.               
  431. FUNCTION LINKSIZE(LINKV:INTEGER):INTEGER;
  432. BEGIN
  433.   IF LINKV >= LINKESCAPE THEN LINKSIZE:=2
  434.                          ELSE LINKSIZE:=1;
  435. END (*LINKSIZE*);
  436.  
  437. PROCEDURE STEPLINK(WI:DBWRKINDEX);
  438. (*advance offset at current level to step over a link-like item (either
  439.   link or tag*)
  440. BEGIN
  441.   WITH WRKTABLE[WI] DO
  442.     WITH WIB^[TOS] DO
  443.       OFFSET:=OFFSET+1+ORD(LINKVALUE(WA,OFFSET) >= LINKESCAPE);
  444. END (*STEPLINK*);
  445.  
  446. PROCEDURE NEXTLINK(WA:WAPTR; VAR OFFSET:PAGEPTR; VAR ITEMNUM:INTEGER);
  447. (*advance offset to next location on list*)
  448. VAR LINKV:INTEGER;
  449. BEGIN
  450.   LINKV:=LINKVALUE(WA,OFFSET);
  451.   (*combine this guy and linkvalue call into one external proc*)
  452.   IF LINKV > 0 THEN
  453.     BEGIN
  454.       OFFSET:=OFFSET+LINKV;
  455.       ITEMNUM:=ITEMNUM+1;
  456.     END;
  457. END (*NEXTLINK*);
  458.  
  459. PROCEDURE SETDESCRIPTORNUM(WI:DBWRKINDEX);
  460. (*gets descriptor number for field # ITEMNUM from list in record descriptor*)
  461. (* group descriptor from enclosing field or tag*)
  462. (* record descriptor from group*)
  463. VAR RP:RECDESPTR;
  464.   GP:GRPDESPTR;
  465.   FP:FLDDESPTR;
  466.   LINKV:INTEGER;
  467. BEGIN
  468.   WITH WRKTABLE[WI] DO
  469.     CASE WIB^[TOS].LEVEL OF
  470.       FIELDT:
  471.         BEGIN (*refer to record's list of descriptor pointers*)
  472.           RP:=ACTIVERECORDS[WIB^[TOS-1].DESCRIPTORNUM];
  473.           WITH RP^ DO
  474.             IF (((LASTFLDLINK-1) DIV SIZEOF(FLDREF))-2) < WIB^[TOS].ITEMNUM THEN
  475.               (*Note: one item only (i.e. itemnum=0) goes with
  476.                 LASTFLDLINK = 5 if FLDREF is 2 bytes; end of list is one
  477.                 FLDREF entry with value of zero as stopper*)
  478.               WIB^[TOS].DESCRIPTORNUM:=-1 (*no such field*)
  479.             ELSE
  480. (*$R-*)
  481.               WITH WIB^[TOS] DO
  482.                 DESCRIPTORNUM:=RP^.FLDREF[ITEMNUM].FDNUM;
  483. (*$R-*)
  484.         END;
  485.       GROUPT:
  486.         (*all groups are tagged*)
  487.         (*descriptor number is tag value at page level*)
  488.         IF TOS=0 THEN
  489.           WITH WIB^[TOS] DO
  490.             BEGIN
  491.               LINKV:=LINKVALUE(WA,OFFSET);
  492.               DESCRIPTORNUM:=LINKVALUE(WA,(OFFSET+LINKSIZE(LINKV)));
  493.             END
  494.         ELSE
  495.           BEGIN (*get from parent field descriptor*)
  496.             FP:=ACTIVEFIELDS[WIB^[TOS-1].DESCRIPTORNUM];
  497.             WITH WIB^[TOS] DO
  498.               DESCRIPTORNUM:=FP^.FLDREF;
  499.           END;
  500.       RECORDT:
  501.         BEGIN (*record is tagged if group specifies mixed records*)
  502.           GP:=ACTIVEGROUPS[WIB^[TOS-1].DESCRIPTORNUM];
  503.           WITH WIB^[TOS] DO
  504.             WITH GP^ DO
  505.               IF RECLINK > ONEITEMRECLINK THEN (*mixed*)
  506.                 BEGIN
  507.                   LINKV:=LINKVALUE(WA,OFFSET);
  508.                   (*get the tag*)
  509.                   DESCRIPTORNUM:=LINKVALUE(WA,OFFSET+LINKSIZE(LINKV));
  510.                 END
  511.               ELSE
  512.                 DESCRIPTORNUM:=RECNUM[0];
  513.         END (*RECORDT:*);
  514.     END (*CASES*);
  515. END (*SETDESCRIPTORNUM*);
  516.  
  517.  
  518. (*TRAVERSAL PRIMITIVES*)
  519. FUNCTION DBHOME(*WI:DBWRKINDEX):DBERRTYPE*);
  520. (*zero out workstack for the workarea, except for its initial location*)
  521. VAR I:INTEGER;
  522. BEGIN
  523.   WITH WRKTABLE[WI] DO
  524.     BEGIN
  525.       IF WA=NIL THEN
  526.         DBHOME:=8 (* workarea not open *)
  527.       ELSE
  528.         BEGIN
  529.           FOR I:=1 TO TOS DO
  530.             WITH WIB^[I] DO
  531.               BEGIN
  532.                 OFFSET:=0;
  533.                 LEVEL:=NONET;
  534.                 DESCRIPTORNUM:=-1;
  535.                 ITEMNUM:=-1;
  536.               END;
  537.           WITH WIB^[0] DO
  538.             BEGIN
  539.               OFFSET:=0;
  540.               ITEMNUM:=0;
  541.               IF DBTYPECHECK THEN SETDESCRIPTORNUM(WI);
  542.             END;
  543.           TOS:=0;
  544.         END (* WA <> NIL *);
  545.     END (*WITH WRKTABLE*);
  546.   TRACEWA(6,WI);
  547. END (*DBHOME*);
  548.  
  549. FUNCTION DBNEXT(*WI:DBWRKINDEX):DBERRTYPE*);
  550. (*move to head of next linked item*)
  551. VAR RP:RECDESPTR;
  552.   BEFOREITEM,DUMMY:INTEGER;
  553. BEGIN
  554.   DBNEXT:=0;
  555.   TRACEWA(7,WI);
  556.   WITH WRKTABLE[WI] DO
  557.     WITH WIB^[TOS] DO
  558.       BEGIN
  559.         BEFOREITEM:=ITEMNUM;
  560.         IF LEVEL = FIELDT THEN
  561.           BEGIN
  562.             RP:=ACTIVERECORDS[WIB^[TOS-1].DESCRIPTORNUM];
  563.             IF RP = NIL THEN
  564.               DBNEXT:=32
  565.             ELSE
  566.               WITH RP^ DO
  567.                 BEGIN
  568.                   IF ITEMNUM < FIRSTLITEMNUM THEN
  569.                     BEGIN
  570.                       ITEMNUM:=ITEMNUM+1;
  571.                       IF ITEMNUM = FIRSTLITEMNUM THEN
  572.                         (*transition from fixed to variable fields*)
  573.                         NEXTLINK(WA,OFFSET,DUMMY);
  574.                     END
  575.                   ELSE
  576.                     NEXTLINK(WA,OFFSET,ITEMNUM);
  577.                 END (*WITH RP^*);
  578.           END (*LEVEL=FIELDT*)
  579.         ELSE
  580.           (*all items assumed to be linked & all lists stopped with nul*)
  581.           NEXTLINK(WA,OFFSET,ITEMNUM);
  582.         IF BEFOREITEM = ITEMNUM THEN
  583.           DBNEXT:=27 (*can't find any more*)
  584.         ELSE
  585.           IF DBTYPECHECK THEN SETDESCRIPTORNUM(WI);
  586.       END;
  587.   TRACEWA(8,WI);
  588. END (*DBNEXT*);
  589.  
  590. FUNCTION DBHEAD(*WI:DBWRKINDEX):DBERRTYPE*);
  591. (*move to head of list at current level*)
  592. VAR LINKV:INTEGER;
  593.   RP:RECDESPTR;
  594.   PARENTOFFSET:PAGEPTR;
  595. BEGIN
  596.   WITH WRKTABLE[WI] DO
  597.     BEGIN
  598.       IF TOS > 0 THEN
  599.         BEGIN
  600.           PARENTOFFSET:=WIB^[TOS-1].OFFSET;
  601.           LINKV:=LINKVALUE(WA,PARENTOFFSET);
  602.           WITH WIB^[TOS] DO
  603.             BEGIN
  604.               OFFSET:=PARENTOFFSET+LINKSIZE(LINKV);
  605.               IF LEVEL = RECORDT THEN (*step over parent group's tag*)
  606.                 STEPLINK(WI);
  607.             END;
  608.         END
  609.       ELSE
  610.         (*global group level - point to head of page*)
  611.         WIB^[TOS].OFFSET:=0;
  612.       WIB^[TOS].ITEMNUM:=0;
  613.       IF DBTYPECHECK THEN SETDESCRIPTORNUM(WI);
  614.     END (*WITH WRKTABLE*);
  615.   TRACEWA(30,WI);
  616. END (*DBHEAD*);
  617.  
  618. FUNCTION DBTAIL(*WI:DBWRKINDEX):DBERRTYPE*);
  619. (*point to link position following last non-nul item at current level*)
  620. VAR RP:RECDESPTR;
  621.   BEFOREITEMNUM:INTEGER;
  622. BEGIN
  623.   WITH WRKTABLE[WI] DO
  624.     WITH WIB^[TOS] DO
  625.       BEGIN
  626.         BEFOREITEMNUM:=ITEMNUM;
  627.         REPEAT
  628.           NEXTLINK(WA,OFFSET,ITEMNUM);
  629.         UNTIL LINKVALUE(WA,OFFSET)=0;
  630.         IF LEVEL = FIELDT THEN
  631.           BEGIN
  632.             RP:=ACTIVERECORDS[WIB^[TOS-1].DESCRIPTORNUM];
  633.             IF RP = NIL THEN
  634.               DBTAIL:=32
  635.             ELSE
  636.               WITH RP^ DO
  637.                 IF BEFOREITEMNUM < FIRSTLITEMNUM THEN
  638.                   ITEMNUM:=ITEMNUM + (FIRSTLITEMNUM-BEFOREITEMNUM-1);
  639.           END (*LEVEL=FIELDT*);
  640.         SETDESCRIPTORNUM(WI);
  641.       END (*WITH WIB*);
  642.   TRACEWA(29,WI);
  643. END (*DBTAIL*);
  644.  
  645.  
  646.