LnSOS BOOT 1.1 SOS.KERNEL SOS KRNLI/O ERRORFILE 'SOS.KERNEL' NOT FOUND%INVALID KERNEL FILE: xةw,@  ȱlmi8#)!)N^ƣ-VIDEOTAPE.INVܢܢ-READ.ME.FIRST  ܢܢ/LISTSTATUS.CODE ܢܢ.INVENTORY.TEXT!@ܢܢ.INVENTORY.CODE ܢܢ.TESTBTREE.TEXT ܢܢ.TESTBTREE.CODEܢܢPUTDEMOu' -TESTUNIT.TEXT'Lܢܢ.TESTUNIT2.TEXT/0ܢܢ-TESTUNIT.CODEH.ܢܢ/CREATEFILE.TEXT`ܢ/CREATEFILE.CODEo ܢܢ/LISTSTATUS.TEXTu >dLԡm#i㰼m#iЕOLԡȱfg hi !dLԡ憦  Ljmkm l y`2 Lԡ8(Je稽)ʈ@L  !"#$%&'()*+,-LE *) & END; (* IF *) &END; (* OF NOALTS *) # #FUNCTION NOBOOL(LINENUM: INTEGER; PRMT: STRING; VAR BOOL: BOOLEAN) ,: BOOLEAN; &(* '* PROMPT FOR 'Y', 'N', OR ESC; '* RETURN TRUE IF ESC WAS INPUT. '* RETURN BOOL= ('Y' WAS INPUT). '*) &BEGe characters (ALTCHR)? ', TMPSTRG); )NOALTS:= TMPBOOL; )IF NOT TMPBOOL THEN ,BEGIN . ALTCHR:= NULLSET; /WHILE LENGTH(TMPSTRG)> 0 DO 2BEGIN 5ALTCHR:= ALTCHR+ [TMPSTRG[LENGTH(TMPSTRG)]]; 5CHGLEN(TMPSTRG, LENGTH(TMPSTRG)- 1); & END; (* WHI'* PROMPT FOR A STRING AND ADD EACH CHARACTER TO '* THE SET 'ALTCHR'. '* RETURN NOALTS= TRUE (ESC OR 'EXIT' WAS INPUT) '* '*) &VAR )TMPBOOL +: BOOLEAN; )TMPSTRG +: STRING; &BEGIN (* NOALTS *) & TMPBOOL:= NOSTRG(LINENUM, ) 'Enter alternatNE, PRMT); )READLN(STRG); & SCREENMSG(0, 23, CLRLINE, NULLSTRG); )TMPSTRG:= STRG; )UPPERCASE(TMPSTRG); )NOSTRG:= (TMPSTRG= 'EXIT'); &END; (* OF NOSTRG *) # #FUNCTION NOALTS(LINENUM: INTEGER) ,: BOOLEAN; &(* ER; PRMT: STRING; VAR STRG: STRING) ,: BOOLEAN; # (* '* PROMPT FOR AND INPUT A STRING. RETURN '* TRUE IF 'EXIT' WAS INPUT. '* '*) &VAR )TMPSTRG +: STRING; &BEGIN (* NOSTRG *) )SCREENMSG(0, 23, CLRLINE, TYPESTRG); ( SCREENMSG(0, LINENUM, CLRLINES(STARTLINE, ENDLINE: INTEGER); &BEGIN (* CLEARLINES *) & WHILE STARTLINE<= ENDLINE DO ,BEGIN /SCREENMSG(0, STARTLINE, CLRLINE, NULLSTRG); /STARTLINE:= STARTLINE+ 1; ,END; (* WHILE *) &END; (* OF CLEARLINES *) & #FUNCTION NOSTRG(LINENUM: INTEG#FUNCTION WANTSTOLEAVE ,: BOOLEAN; &(* '* WAIT FOR RETURN OR ESCAPE; '* SET FUNCTION VALUE TO ESCTYPED; '* '*) # BEGIN (* WANTSTOLEAVE *) & RESPOND(QUIET, TYPERET); )WANTSTOLEAVE:= ESCTYPED; &END; (* OF WANTSTOLEAVE *) & #PROCEDURE CLEARLIHRPOS])- 32); &END; (* OF UPPERCASE *) & #PROCEDURE DISPPURPOSE(PURPOSE: STRING); &(* '* DISPLAY THE PURPOSE OF A MODULE '* '*) &BEGIN (* DISPPURPOSE *) )SCREENMSG(0, 2, NULLCMD, '** '); )WRITE(PURPOSE); &END; (* OF DISPPURPOSE *) # INTEGER; # #PROCEDURE UPPERCASE(VAR STRG: STRING); &(* '* MAKE STRG ALL UPPER CASE '* '*) &VAR )CHRPOS +: INTEGER; &BEGIN (* UPPERCASE *) )FOR CHRPOS:= 1 TO LENGTH(STRG) DO ,IF ORD(STRG[CHRPOS]) IN [97..122] THEN /STRG[CHRPOS]:= CHR(ORD(STRG[CYPENUM= 'Enter a number, or Type [ESCAPE] to leave'; &TYPESTRG= 'Enter a string, or Enter EXIT to leave'; &TYPEYORN= 'Type Y or N, or Type [ESCAPE] to leave'; # TYPELRC= 'Type L(eft, R(ight, or C(enter, or Type [ESCAPE] to leave'; #VAR &NUMSELS (:  (*$S++*)  (*$V-*)  PROGRAM TESTUNIT; #(* $* TESTS THE GENERAL UTILITIES MODULES # * $*) $USES &APPLESTUFF, &GENUTIL; # #CONST &TYPERET= 'Type [RETURN], or Type [ESCAPE] to leave'; &TYPECHR= 'Type a character, or Type [ESCAPE] to leave'; &TIN (* NOBOOL *) )SCREENMSG(0, 23, CLRLINE, TYPEYORN); )SCREENMSG(0, LINENUM, CLRLINE, PRMT); )GETCHR(0, FALSE, ['Y', 'y', 'N', 'n', ESC]); )IF NOT ESCTYPED THEN ,WRITELN(RSPCHR); )SCREENMSG(0, 23, CLRLINE, NULLSTRG); )NOBOOL:= ESCTYPED; )BOOL:= (RSPCHR IN ['Y', 'y']); &END; (* OF NOBOOL *) # #FUNCTION NONUM(LINENUM: INTEGER; PRMT: STRING; VAR NUM: INTEGER) ,: BOOLEAN; # (* '* PROMPT FOR AND INPUT A NUMBER. RETURN '* TRUE IF 'EXIT' WAS INPUT. '* '*) &VAR )TMPINT +: INTEGER; E) /ELSE 2WRITELN(RSPDATE, ' is greater than ', TMPDATE); & IF WANTSTOLEAVE THEN /EXIT(TESTDATECOMPARE); ) CLEARLINES(6, 8); )UNTIL FALSE; &END; (* OF TESTDATECOMPARE *) #PROCEDURE TESTDELAY; &VAR )DURATION +: INTEGER; &BEGIN (* TESTDELESTDATECOMPARE); , ,(* TEST CALL *) ,RESULT:= DATECOMPARE(RSPDATE, TMPDATE); , ,SCREENMSG(0, 8, CLRLINE, NULLSTRG); ,IF RESULT< 0 THEN /WRITELN(RSPDATE, ' is less than ', TMPDATE) ,ELSE /IF RESULT= 0 THEN 2WRITELN(RSPDATE, ' is equal to ', TMPDAT& STDSCREEN('Testing DATECOMPARE'); )DISPPURPOSE('Compare two dates.'); )TMPDATE:= '061581'; )SCREENMSG(0, 4, NULLCMD, 'Right-hand date (RIGHTDATE) is '); )WRITE(TMPDATE); )REPEAT ,IF NOSTRG(6, 'Left-hand date (LEFTDATE)? ', RSPDATE) THEN /EXIT(T ,IF WANTSTOLEAVE THEN /EXIT(TESTCHGLEN); & CLEARLINES(5, 8); )UNTIL FALSE; &END; (* OF TESTCHGLEN *) # #PROCEDURE TESTDATECOMPARE; &VAR )RESULT +: INTEGER; )TMPDATE, )RSPDATE +: STRING; &BEGIN (* TESTDATECOMPARE *) ; ,IF NONUM(5, 'New length of STRG (NEWLEN)? ', NEWLEN) THEN /EXIT(TESTCHGLEN); 2 ,(* TEST CALL *) ,CHGLEN(STRG, NEWLEN); 2 ,SCREENMSG(0, 7, CLRLINE, 7'Resulting STRG is between > and < below.'); ,SCREENMSG(0, 8, CLRLINE, '>'); ,WRITE(STRG, '<');INTEGER; &BEGIN (* TESTCHGLEN *) )STDSCREEN('Testing CHGLEN'); )DISPPURPOSE('Change the length of a string.'); )CHGLEN(STRG, 80); )FILLCHAR(STRG[1], LENGTH(STRG), 'X'); )REPEAT ,IF NOSTRG(4, 'String to change (STRG)? ', STRG) THEN /EXIT(TESTCHGLEN))SCREENMSG(0, 23, CLRLINE, NULLSTRG); )NODIR:= ESCTYPED; )CASE RSPCHR OF ,'L', 'l': DIR:= LEFT; ,'R', 'r': DIR:= RIGHT; ,'C', 'c': DIR:= CENTER; ,END; (* CASE *) &END; (* OF NODIR *) # #PROCEDURE TESTCHGLEN; &VAR )STRG ,: STRING; )NEWLEN +: ; VAR DIR: DIRECTION) ,: BOOLEAN; &BEGIN (* NODIR *) )SCREENMSG(0, 23, CLRLINE, TYPELRC); )SCREENMSG(0, LINENUM, CLRLINE, PRMT); )GETCHR(0, FALSE, ['L', 'l', 'R', 'r', 'C', 'c', ESC]); )IF NOT ESCTYPED THEN ,WRITELN(RSPCHR); LRLINE, TYPECHR); )SCREENMSG(0, LINENUM, CLRLINE, PRMT); )GETCHR(-1, FALSE, []); )IF NOT ESCTYPED THEN ,WRITELN(RSPCHR); )SCREENMSG(0, 23, CLRLINE, NULLSTRG); )NOCHR:= ESCTYPED; &END; (* OF NOCHR *) # #FUNCTION NODIR(LINENUM: INTEGER; PRMT: STRINGN (* NOATTR *) )NOATTR:= NOBOOL(LINENUM, PRMT, TMPBOOL); )IF NOT ESCTYPED THEN ,IF TMPBOOL THEN /ATTRSET:= ATTRSET+ [ATTR]; &END; (* OF NOBOOL *) # #FUNCTION NOCHR(LINENUM: INTEGER; PRMT: STRING) ,: BOOLEAN; &BEGIN (* NOCHR *) )SCREENMSG(0, 23, C/BEGIN 2VALID:= TRUE; & SELECTION:= NUM; /END; (* IF *) )UNTIL VALID; &END; (* OF SELECTION *) & #FUNCTION NOATTR(LINENUM: INTEGER; PRMT: STRING; ATTR: ATTRIBUTE; 5VAR ATTRSET: ATTRIBSET) ,: BOOLEAN; &VAR )TMPBOOL +: BOOLEAN; &BEGITION ,: INTEGER; &VAR )VALID +: BOOLEAN; & NUM +: INTEGER; &BEGIN (* SELECTION *) )VALID:= FALSE; )SELECTION:= 0; )REPEAT ) IF NONUM(22, 'Your Choice? ', NUM) THEN /EXIT(PROGRAM); ,IF (NUM< 1) OR (NUM> NUMSELS) THEN /SOUNDBELL ,ELSE LLSTRG); ,NONUM:= ESCTYPED; ,EVALUATE(NUMSTRG, TMPLONG, TMPINT); ,IF (TMPLONG>= -32767) AND (TMPLONG<= 32767) THEN /BEGIN 2NUM:= TRUNC(TMPLONG); , EXIT(NONUM); , END ,ELSE /SOUNDBELL; )UNTIL FALSE; &END; (* OF NONUM *) # #FUNCTION SELEC)TMPLONG +: LONG; )NUMSTRG +: STRING; &BEGIN (* NONUM *) )SCREENMSG(0, LINENUM, CLRLINE, PRMT); ( REPEAT ,SCREENMSG(0, 23, CLRLINE, TYPENUM); ,PROMPT(LENGTH(PRMT), LINENUM, 5, NULLSTRG, NUMSTRG, 5[SIGNED, NUMERIC]); ,SCREENMSG(0, 23, CLRLINE, NUAY *) )STDSCREEN('Testing DELAY'); )DISPPURPOSE('Delay a small interval of time.'); )REPEAT ,IF NONUM(4, 'Wait how long (DURATION)? ', DURATION) THEN /EXIT(TESTDELAY); ,SCREENMSG(0, 6, CLRLINE, 'Waiting for a count of '); ,WRITE(DURATION, '...'); , ,(* TEST CALL *) ,DELAY(DURATION); , & SCREENMSG(0, 6, CLRLINE, NULLSTRG); ,IF WANTSTOLEAVE THEN /EXIT(TESTDELAY); )UNTIL FALSE; &END; (* OF TESTDELAY *) # #PROCEDURE TESTEVALUATE; &VAR )CURPOS ,: INTEGER; )VALUE ,: LONG; )SRC ,: S(TMPSTRG, OUTSTRG, ATTRSET); , ,SCREENMSG(0, 12, CLRLINE, 'Formatted string (FMTSTRG) is '); ,WRITE(OUTSTRG); ,IF WANTSTOLEAVE THEN /EXIT(TESTFMTDATE); ) CLEARLINES(5, 12); )UNTIL FALSE; &END; (* OF TESTFMTDATE *) # #PROCEDURE GETNUMATTR(LINENU,MAKESTRG(RSPCHR, DATEDELIM); ,IF NOSTRG(5, 'Date string (DATESTRG)? ', TMPSTRG) THEN /EXIT(TESTFMTDATE); ,(* GET DATE FORMAT ATTRIBUTES *) ,ATTRSET:= []; ,GETDATEATTR(6, ATTRSET); ,IF ESCTYPED THEN /EXIT(TESTFMTDATE); 2 ,(* TEST CALL *) ,FMTDATE& STDSCREEN('Testing FMTDATE'); )DISPPURPOSE( )'Format a numeric string as a date in a variety of formats.'); )REPEAT ,IF NOCHR(4, 'Delimiter between month, day, year (DATEDELIM)? ') THEN /EXIT(TESTFMTDATE); ,IF RSPCHR= RET THEN /RSPCHR:= DASH; (LINENUM+ 5, 'Four-digit year (FULLYEAR)? ', FULLYEAR, .ATTRSET) THEN ,EXIT(GETDATEATTR); &END; (* OF GETDATEATTR *) # #PROCEDURE TESTFMTDATE; &VAR )ATTRSET ,: ATTRIBSET; )OUTSTRG, )TMPSTRG +: STRING; &BEGIN (* TESTFMTDATE *) SET) THEN ,EXIT(GETDATEATTR); )IF NOATTR(LINENUM+ 3, .'Full month name (FULLMON)? ', FULLMON, ATTRSET) THEN ,EXIT(GETDATEATTR); )IF NOATTR(LINENUM+ 4, 'Abbreviate month name (ABBRMON)? ', .ABBRMON, ATTRSET) THEN ,EXIT(GETDATEATTR); # IF NOATTRBSET); &BEGIN (* GETDATEATTR *) )SCREENMSG(0, LINENUM, NULLCMD, 'Date attributes:'); )IF NOATTR(LINENUM+ 1, .'Year, month, day order (YMD)? ', YMD, ATTRSET) THEN ,EXIT(GETDATEATTR); )IF NOATTR(LINENUM+ 2, .'Day, month, year order (DMY)? ', DMY, ATTR/'First non-matching character position (FIRSTNON) is '); ,WRITELN(TMPINT); ) IF WANTSTOLEAVE THEN /EXIT(TESTFIRSTNON); ) CLEARLINES(5, 8); )UNTIL FALSE; &END; (* OF TESTFIRSTNON *)  #PROCEDURE GETDATEATTR(LINENUM: INTEGER; VAR ATTRSET: ATTRIacter to scan for (PADCHR)? ') THEN /EXIT(TESTFIRSTNON); ,TMPCHR:= RSPCHR; ,IF NOSTRG(6, 'String to scan (SRCSTRG)? ', SRC) THEN /EXIT(TESTFIRSTNON); , ,(* TEST CALL *) ,TMPINT:= FIRSTNON(TMPDIR, TMPCHR, SRC); , ,SCREENMSG(0, 8, CLRLINE, SRC ,: STRING; &BEGIN (* TESTFIRSTNON *) )STDSCREEN('Testing FIRSTNON'); )DISPPURPOSE('Scan a string from the left or right.'); )REPEAT ,IF NODIR(4, 'Scan from which direction (HOWJUST)? ', TMPDIR) THEN /EXIT(TESTFIRSTNON); ,IF NOCHR(5, 'Which char position (CURPOS) is '); ,WRITELN(CURPOS); ) IF WANTSTOLEAVE THEN /EXIT(TESTEVINT); ) CLEARLINES(6, 7); )UNTIL FALSE; &END; (* OF TESTEVINT *) # #PROCEDURE TESTFIRSTNON; &VAR )TMPDIR ,: DIRECTION; )TMPCHR ,: CHAR; )TMPINT ,: INTEGER; ),IF NOSTRG(4, 'String to evaluate (STRG)? ', SRC) THEN /EXIT(TESTEVINT); , ,(* TEST CALL *) ,INTVAL:= EVALINT(SRC, CURPOS); , ,SCREENMSG(0, 6, CLRLINE, 'Function value (EVALINT) is '); ,WRITELN(INTVAL); ,SCREENMSG(0, 7, CLRLINE, 'First non-numericEND; (* OF TESTEVALUATE *) & #PROCEDURE TESTEVINT; &VAR )INTVAL ,: INTEGER; & CURPOS ,: INTEGER; )SRC ,: STRING; &BEGIN (* TESTEVINT *) & STDSCREEN('Testing EVALINT'); )DISPPURPOSE('Evaluate a numeric string as an INTEGER.'); )REPEAT VALUE, CURPOS); , ) SCREENMSG(0, 6, CLRLINE, 'VALUE is '); ,WRITELN(VALUE); ,SCREENMSG(0, 7, CLRLINE,'First non-numeric position (CURPOS) is '); ,WRITELN(CURPOS); ,IF WANTSTOLEAVE THEN /EXIT(TESTEVALUATE); ) CLEARLINES(6, 7); )UNTIL FALSE; &TRING; &BEGIN (* TESTEVALUATE *) & STDSCREEN('Testing EVALUATE'); )DISPPURPOSE('Evaluate a numeric string as a LONG INTEGER.'); )REPEAT ,IF NOSTRG(4, 'String to evaluate (STRG)? ', SRC) THEN /EXIT(TESTEVALUATE); , ,(* TEST CALL *) ,EVALUATE(SRC,M: INTEGER; VAR ATTRSET: ATTRIBSET); &BEGIN (* GETNUMATTR *) )SCREENMSG(0, LINENUM, CLRLINE, 'Numeric Attributes:'); )IF NOATTR(LINENUM+ 1, 'Insert commas (COMMAS)? ', COMMAS, ATTRSET) THEN ,EXIT(GETNUMATTR); )IF NOATTR(LINENUM+ 2, 'Insert a decimal point (DECIMAL)? ', .DECIMAL, ATTRSET) THEN ,EXIT(GETNUMATTR); )IF NOATTR(LINENUM+ 3, 'Insert a dollar sign (DOLLAR)? ', .DOLLAR, ATTRSET) THEN ,EXIT(GETNUMATTR); )IF NOATTR(LINENUM+ 4, 'Fixed dollar sign or S(5, 8); )UNTIL FALSE; &END; (* OF TESTGETCHR *) # #PROCEDURE TESTJUSTIFY; &VAR )TMPDIR ,: DIRECTION; )TMPCHR ,: CHAR; )TMPINT ,: INTEGER; )SRC ,: STRING; )DEST ,: STRING; &BEGIN (* TESTJUSTIFY *) & STDSCREEN('Testing JUSTIFY'); )DISPPUIDCHR+ [TMPSTRG[LENGTH(TMPSTRG)]]; 2CHGLEN(TMPSTRG, LENGTH(TMPSTRG)- 1); /END; (* WHILE *) / ,GOTOXY(0, 8); , ,(* TEST CALL *) ,GETCHR(NUMDELAYS, WITHBELLS, VALIDCHR); , ,WRITEORD; ) & IF WANTSTOLEAVE THEN /EXIT(TESTGETCHR); , ,CLEARLINE,IF NOBOOL(5, 'Sound bells (WITHBELLS)? ', WITHBELLS) THEN /EXIT(TESTGETCHR); , ,IF NOSTRG(6, 'String of valid characters (VALIDCHR)? ', 1TMPSTRG) THEN /EXIT(TESTGETCHR); / ,VALIDCHR:= NULLSET; ,WHILE LENGTH(TMPSTRG)> 0 DO /BEGIN 2VALIDCHR:= VAL&BEGIN (* TESTGETCHR *) )STDSCREEN('Testing GETCHR'); ) )DISPPURPOSE('Gets a character from the keyboard.'); ) )REPEAT ,IF NONUM(4, 'Number of delays (NUMDELAYS)? ', NUMDELAYS) THEN /EXIT(TESTGETCHR); / ; &PROCEDURE WRITEORD; )BEGIN (* WRITEORD *) & IF ESCTYPED THEN /TMPSTRG:= 'TRUE' ,ELSE /TMPSTRG:= 'FALSE'; ,SCREENMSG(0, 8, CLRLINE, 'ASCII value of RSPCHR is '); ,WRITELN(ORD(RSPCHR), '; ESCTYPED is ', TMPSTRG); )END; (* OF WRITEORD *) & INES(10, 20); 5END; (* IF *) /END; (* WHILE *); ,CLEARLINES(7, 20); )UNTIL FALSE; &END; (* OF TESTFMTNUM *) # # #PROCEDURE TESTGETCHR; &VAR & WITHBELLS +: BOOLEAN; )NUMDELAYS, )TMPINT +: INTEGER; )VALIDCHR +: CHARSET; )TMPSTRG +: STRING8FMTNUM(TMPSTRG, OUTSTRG, HOWJUST, MAXLEN, ATTRSET); 8 8BACKGROUND:= SPACE; 8NUMPLACES:= 0; 8MINDIGITS:= 0; 8SCREENMSG(5, 20, CLRLINE, C'Formatted string (FMTSTRG) is '); 8WRITE(OUTSTRG); 8IF WANTSTOLEAVE THEN ;EXIT(TESTFMTNUM); / CLEARLRMAT ATTRIBUTES *) 2ATTRSET:= []; 2GETNUMATTR(10, ATTRSET); 2IF NOT ESCTYPED THEN 2 BEGIN 5 8BACKGROUND:= TMPBACKGROUND; 8NUMPLACES:= TMPNUMPLACES; 8MINDIGITS:= TMPMINDIGITS; 8 8(* TEST CALL *) ,(* GET HOWJUST *) ,IF NODIR(8, 'Justification (HOWJUST)? ', HOWJUST) THEN /EXIT(TESTFMTNUM); ,(* GET MAXLEN *) ,IF NONUM(9, 'Maximum number of digits (MAXLEN)? ', MAXLEN) THEN /EXIT(TESTFMTNUM); ,WHILE NOT ESCTYPED DO , BEGIN 2(* GET NUMERIC FOTNUM); )(* GET MINDIGITS *) )IF NONUM(6, 'Minimum number of digits (MINDIGITS)? ', .TMPMINDIGITS) THEN ,EXIT(TESTFMTNUM); )REPEAT ,SCREENMSG(0, 7, CLRLINE, NULLSTRG); ,IF NOSTRG(7, 'Unformatted string (RAWSTRG)? ', TMPSTRG) THEN /EXIT(TESTFMTNUM); )IF NOCHR(4, 'Background character (BACKGROUND)? ') THEN ,EXIT(TESTFMTNUM); )IF RSPCHR= RET THEN ,RSPCHR:= SPACE; )TMPBACKGROUND:= RSPCHR; )(* GET NUMPLACES *) )IF NONUM(5, 'Number of decimal places (NUMPLACES)? ', .TMPNUMPLACES) THEN ,EXIT(TESTFMS +: INTEGER; )TMPBACKGROUND +: CHAR; )ATTRSET ,: ATTRIBSET; )OUTSTRG, )TMPSTRG +: STRING; &BEGIN (* TESTFMTNUM *) & STDSCREEN('Testing FMTNUM'); )(* GET BACKGROUND *) )DISPPURPOSE('Format and justify a numeric string.'); EXIT(GETNUMATTR); )IF NOATTR(LINENUM+ 7, 'Trailing minus sign (TRAILMINUS)? ', .TRAILMINUS, ATTRSET) THEN ,EXIT(GETNUMATTR); # END; (* OF GETNUMATTR *) # #PROCEDURE TESTFMTNUM; &VAR ( HOWJUST +: DIRECTION; )MAXLEN, )TMPMINDIGITS, )TMPNUMPLACEparentheses (FIXED)? ', .FIXED, ATTRSET) THEN ,EXIT(GETNUMATTR); )IF NOATTR(LINENUM+ 5, 'Is this a signed number (SIGNED)? ', .SIGNED, ATTRSET) THEN ,EXIT(GETNUMATTR); )IF NOATTR(LINENUM+ 6, 'Insert parentheses (PARENS)? ', .PARENS, ATTRSET) THEN ,RPOSE('Left-, Center-, or Right-Justify a string.'); )REPEAT ,IF NOSTRG(4, 'String to justify (SRCSTRG)? ', SRC) THEN /EXIT(TESTJUSTIFY); ) IF NODIR(5, 'Which direction (HOWJUST)? ', TMPDIR) THEN /EXIT(TESTJUSTIFY); ,IF NOCHR(6, 'Background character (PADCHR)? ') THEN /EXIT(TESTJUSTIFY); ,IF RSPCHR= RET THEN /RSPCHR:= SPACE ,ELSE /TMPCHR:= RSPCHR; ,IF NONUM(7, 'Desired length of justified string (NEWLEN)? ', 7TMPINT) THEN /EXIT(TESTJUSTIFY); , ,(* TEST CALL.0123456789:;<=>?@ABCDEFN^ƣ 'Remainder (LREMDR) is '); ,WRITELN(REMDR); ,IF WANTSTOLEAVE THEN /EXIT(TESTLONGDIV); ,CLEARLINES(5, 8); )UNTIL FALSE; &END; (* OF TESTLONGDIV *) # #(*$I PUTDEMO:TESTUNIT2.TEXT *) # ; ,EVALUATE(DVDNDSTRG, DIVIDEND, TMPINT); ,EVALUATE(DVSRSTRG, DIVISOR, TMPINT); , ,(* TEST CALL *) ,LONGDIV(DIVIDEND, DIVISOR, QUOTIENT, REMDR); , ,SCREENMSG(0, 7, CLRLINE, 'Quotient (LQUOTIENT) is '); ,WRITELN(QUOTIENT); ,SCREENMSG(0, 8, CLRLINE,+: STRING; &BEGIN (* TESTLONGDIV *) )STDSCREEN('Testing LONGDIV'); & DISPPURPOSE('Does LONG INTEGER division.'); )REPEAT ,IF NOSTRG(4, 'DIVIDEND? ', DVDNDSTRG) THEN /EXIT(TESTLONGDIV); ,IF NOSTRG(5, 'DIVISOR? ', DVSRSTRG) THEN /EXIT(TESTLONGDIV)esting LOCATE'); )DISPPURPOSE('Locate an entry on a "page" of entries.'); )TLOCATE; &END; (* OF TESTLOCATE *)  #PROCEDURE TESTLONGDIV; &VAR )TMPINT +: INTEGER; )DIVIDEND, )DIVISOR, )QUOTIENT, )REMDR +: LONG; )DVDNDSTRG, )DVSRSTRG es (RESRVD)? ', RESRVD) THEN 2EXIT(TLOCATE); /IF NONUM(8, 'Size of displacement, in bytes (DISPLACE)? ', 4DISPLACE) THEN 2EXIT(TLOCATE); /LOCENT; , CLEARLINES(5, 12); ,UNTIL FALSE; )END; (* OF TLOCATE *) # &BEGIN (* TESTLOCATE *) )STDSCREEN('TPEAT /IF NOBOOL(4, 'Are entries BLOCKED? ', BLOCKED) THEN 2EXIT(TLOCATE); /IF NONUM(5, 'Entry length (ENTLEN)? ', ENTLEN) THEN 2EXIT(TLOCATE); /IF NONUM(6, 'Page length (PAGELEN)? ', PAGELEN) THEN 2EXIT(TLOCATE); /IF NONUM(7, 'Number of reserved byt:PAGENUM); , SCREENMSG(0, 12, CLRLINE, NULLSTRG); /WRITELN('Position (POSNUM) is ', POSNUM); , /IF WANTSTOLEAVE THEN 2EXIT(LOCENT); , CLEARLINES(11, 12); ,UNTIL FALSE; )END; (* OF LOCENT *) & &PROCEDURE TLOCATE; )BEGIN (* TLOCATE *) ,RE/IF NONUM(10, 'Entry number (ENTNUM)? ', ENTNUM) THEN 2EXIT(LOCENT); / /(* TEST CALL *) /LOCATE(BLOCKED, ENTNUM, ENTLEN, PAGELEN, RESRVD, DISPLACE, 8PAGENUM, POSNUM); / /SCREENMSG(0, 11, CLRLINE, NULLSTRG); /WRITELN('Page number (PAGENUM) is ', LINES(5, 10); )UNTIL FALSE; &END; (* OF TESTJUSTIFY *) # #PROCEDURE TESTLOCATE; &VAR )BLOCKED +: BOOLEAN; )PAGENUM, )PAGELEN, )POSNUM, )ENTLEN, )ENTNUM, )DISPLACE, )RESRVD +: INTEGER; & & &PROCEDURE LOCENT; )BEGIN (* LOCENT *) ,REPEAT  *) ,JUSTIFY(SRC, DEST, TMPDIR, TMPCHR, TMPINT); ) ,SCREENMSG(0, 9, CLRLINE, .'Resulting string (DSTSTRG) is between > and < below.'); ,SCREENMSG(0, 10, CLRLINE, '>'); ,WRITE(DEST, '<'); ) ,IF WANTSTOLEAVE THEN /EXIT(TESTJUSTIFY); ) CLEAR/SCREENMSG(0, 16, CLRLINE, '>'); /WRITE(RESPONSE, '<'); ) /IF NOT WANTSTOLEAVE THEN 2CLEARLINES(15, 16); 2 ,UNTIL ESCTYPED; ) ) CLEARLINES(5, 16); ) )UNTIL FALSE; &END; (* OF TESTPROMPT *) # #PROCEDURE TESTREPORT; &VAR )TMPBOOL +: BOOIGITS; / /(* TEST CALL *) /PROMPT(5, 10, MAXLEN, DEFAULT, RESPONSE, ATTRSET); / /BACKGROUND:= SPACE; /NUMPLACES:= 0; /MINDIGITS:= 0; / /DEFAULT:= RESPONSE; /SCREENMSG(0, 15, CLRLINE, 'Response is between > and < below.'); MAXLEN *) ,IF NONUM(11, 'Maximum response length (RSPLEN)? ', MAXLEN) THEN /EXIT(TESTPROMPT); , ,IF NOALTS(12) THEN /EXIT(TESTPROMPT); , ,STDSCREEN(BANNER); ,REPEAT / /BACKGROUND:= TMPBACKGROUND; /NUMPLACES:= TMPNUMPLACES; /MINDIGITS:= TMPMIND, ,(* GET NUMPLACES *) ,IF NONUM(9, 'Number of decimal places (NUMPLACES)? ', 7TMPNUMPLACES) THEN /EXIT(TESTPROMPT); , ,(* GET MINDIGITS *) ,IF NONUM(10, 'Minimum number of digits (MINDIGITS)? ', 7TMPMINDIGITS) THEN /EXIT(TESTPROMPT); , ,(* GET,GETNUMATTR(9, ATTRSET); ,IF ESCTYPED THEN /EXIT(TESTPROMPT); , ,CLEARLINES(9, 16); ,(* GET BACKGROUND *) ,IF NOCHR(8, 'Background character (BACKGROUND)? ') THEN /EXIT(TESTPROMPT); ,IF RSPCHR= RET THEN /RSPCHR:= SPACE; ,TMPBACKGROUND:= RSPCHR; TEATTR(9, ATTRSET); ,IF ESCTYPED THEN /EXIT(TESTPROMPT); , ,IF NOCHR(15, 1'Delimiter between month, day, year (DATEDELIM)? ') THEN /EXIT(TESTFMTDATE); ,IF RSPCHR= RET THEN /RSPCHR:= DASH; ,MAKESTRG(RSPCHR, DATEDELIM); , ,CLEARLINES(9, 15); R:='Testing PROMPT'; )STDSCREEN(BANNER); )REPEAT ,DISPPURPOSE( ''Prompt on the screen for a response of the specified type and length.'); ,DEFAULT:= NULLSTRG; ,ATTRSET:= []; ,GETMISCATTR(4, ATTRSET); ,IF ESCTYPED THEN /EXIT(TESTPROMPT); , ,GETDAFALSE; &END; (* OF TESTMAKESTRG *) & #PROCEDURE TESTPROMPT; &VAR )MAXLEN, )TMPNUMPLACES, )TMPMINDIGITS +: INTEGER; )ATTRSET +: ATTRIBSET; )BANNER, )DEFAULT, )RESPONSE +: STRING; & TMPBACKGROUND +: CHAR; & &BEGIN (* TESTPROMPT *) )BANNE,MAKESTRG(RSPCHR, TMPSTRG); , ,SCREENMSG(0, 5, CLRLINE, 'Resulting string (STRG) is '); ,WRITE(TMPSTRG); ,WRITE(' (Length is ', LENGTH(TMPSTRG), ')'); & IF WANTSTOLEAVE THEN /EXIT(TESTMAKESTRG); ) SCREENMSG(0, 5, CLRLINE, NULLSTRG); )UNTIL NG[1]; &BEGIN (* TESTMAKESTRG *) & STDSCREEN('Testing MAKESTRG'); )DISPPURPOSE('Turn a character into a one byte string.'); )REPEAT ,IF NOCHR(4, 'Character to use (CH)? ') THEN /EXIT(TESTMAKESTRG); , ,(* TEST CALL *) ECHO)? ', .NOECHO, ATTRSET) THEN ,EXIT(GETMISCATTR); )IF NOATTR(LINENUM+ 4, 'Disable ESCAPE from the prompt (NOESC)? ', .NOESC, ATTRSET) THEN ,EXIT(GETMISCATTR); # END; (* OF GETMISCATTR *) # # #PROCEDURE TESTMAKESTRG; &VAR & TMPSTRG *: STRIDDATE)? ', .STDDATE, ATTRSET) THEN ,EXIT(GETMISCATTR); )IF NOATTR(LINENUM+ 2, .'Are only alternate characters allowed (ALTONLY)? ', .ALTONLY, ATTRSET) THEN ,EXIT(GETMISCATTR); )IF NOATTR(LINENUM+ 3, .'Suppress echoing of the terminated response (NO#PROCEDURE GETMISCATTR(LINENUM: INTEGER; VAR ATTRSET: ATTRIBSET); &BEGIN (* GETMISCATTR *) )IF NOATTR(LINENUM, 'Is the desired response NUMERIC? ', .NUMERIC, ATTRSET) THEN ,EXIT(GETMISCATTR); )IF NOATTR(LINENUM+ 1, 'Is the desired response a date (STLEAN; )ITEMNUM +: INTEGER; &PROCEDURE PRINTHDR; )VAR ,LINENUM .: INTEGER; )BEGIN (* PRINTHDR *) ,GOTOXY(3, 1); ,WRITE('DUMMY REPORT HEADING LINE'); ,GOTOXY(71, 1); ,WRITELN('Page: ', REPORTCTRL.PAGENUMBER); ,WITH REPORTCTRL DO /LINESONPAGE:= LINESONPAGE+ 2; ,FOR LINENUM:= 18 DOWNTO 3 DO /SCREENMSG(0, LINENUM, CLRLINE, NULLSTRG); )END; (* OF PRINTHDR *) & &BEGIN (* TESTREPORT *) ) )STDSCREEN('Testing Report Controls'); ) )DISPPURPOSE('This test procedure uses:'); )SCREENMSG(2, 4, NULLC& UNTIL FALSE; &END; (* OF TESTSOUNDBELL *) # #PROCEDURE TESTSTDSCREEN; %VAR (BANNER *: STRING; %BEGIN (* TESTSTDSCREEN *) % STDSCREEN('Testing STDSCREEN'); (SCREENMSG(0, 2, CLRLINE, 'Display a standard screen.'); (REPEAT +IF NOSTRG(4, 'Whang SOUNDBELL...'); )DISPPURPOSE('Sounds a bell.'); )REPEAT ,IF NONUM(4, 'Number of bells? ', NUMBELLS) THEN /EXIT(TESTSOUNDBELL); ,FOR TMPINT:= 1 TO NUMBELLS DO /BEGIN 2DELAY(300); 2 2(* TEST CALL *) 2SOUNDBELL; / /END; (* FOR *) TMPCMD, TMPSTRG); ) ) IF WANTSTOLEAVE THEN /EXIT(TESTSCREENMSG); ) CLEARLINES(4, 20); )UNTIL FALSE; &END; (* OF TESTSCREENMSG *) # #PROCEDURE TESTSOUNDBELL; &VAR )NUMBELLS, )TMPINT +: INTEGER; &BEGIN (* TESTSOUNDBELL *) )STDSCREEN('Testi; , ,CASE RSPCHR OF /'N', 'n': TMPCMD:= NULLCMD; /'L', 'l': TMPCMD:= CLRLINE; /'S', 's': TMPCMD:= CLRSCREEN; /END; (* CASE *) , ,IF NOSTRG(7, 'What is the MESSAGE? ', TMPSTRG) THEN /EXIT(TESTSCREENMSG); , ,(* TEST CALL *) ,SCREENMSG(MSGX, MSGY,,SCREENMSG(0, 23, CLRLINE, TYPENLS); ,SCREENMSG(0, 6, CLRLINE, 'Clearing option (COMMAND)? '); , ,GETCHR(0, FALSE, ['N', 'n', 'L', 'l', 'S', 's', ESC]); ,WRITELN(RSPCHR); ,SCREENMSG(0, 23, CLRLINE, NULLSTRG); ,IF ESCTYPED THEN /EXIT(TESTSCREENMSG)SG'); & DISPPURPOSE('Display a message on the screen.'); )REPEAT ,IF NONUM(4, 'Beginning screen column (XPOS)? ', MSGX) THEN /EXIT(TESTSCREENMSG); ,IF NONUM(5, 'Screen line (YPOS)? ', MSGY) THEN /EXIT(TESTSCREENMSG); POND *) # #PROCEDURE TESTSCREENMSG; &CONST )TYPENLS= 'Type N(ullcmd, L(ine, S(creen, or Type [ESCAPE] to leave.'; &VAR ( MSGX, )MSGY +: INTEGER; )TMPCMD +: SCRCOMMAND; )TMPSTRG +: STRING; &BEGIN (* TESTSCREENMSG *) )STDSCREEN('Testing SCREENMKIND:= WARNING; .'A', 'a': MSGKIND:= ATTENTION; .END; (* CASE *) ,IF NOSTRG(7, 'What is the MESSAGE? ', TMPSTRG) THEN /EXIT(TESTRESPOND); , ,(* TEST CALL *) ,RESPOND(MSGKIND, TMPSTRG); & ) CLEARLINES(6, 7); )UNTIL FALSE; &END; (* OF TESTRES,GETCHR(0, FALSE, ['Q', 'q', 'E', 'e', 'W', 'w', 'A', 'a', ESC]); ,IF ESCTYPED THEN /EXIT(TESTRESPOND); ,WRITELN(RSPCHR); ,SCREENMSG(0, 23, CLRLINE, NULLSTRG); ,CASE RSPCHR OF .'Q', 'q': MSGKIND:= QUIET; .'E', 'e': MSGKIND:= ERROR; .'W', 'w': MSGtion'); )SCREENMSG(2, 3, NULLCMD, 'and wait for a character.'); )REPEAT ,IF NOALTS(5) THEN /EXIT(TESTRESPOND); ,SCREENMSG(0, 23, NULLCMD, TYPEQEWA); ,SCREENMSG(0, 6, CLRLINE, 'What kind of message (MSGKIND)? '); EQEWA= ('Type Q(uiet, E(rror, W(arning, A(ttention, or Type [ESCAPE] to leave.'; &VAR )MSGKIND +: MSGTYPE; )TMPSTRG +: STRING; &BEGIN (* TESTRESPOND *) & STDSCREEN('Testing RESPOND'); )DISPPURPOSE( ) 'Display a message at a standard screen locaE 5PRINTHDR; /GOTOXY(0, REPORTCTRL.LINESONPAGE); /WRITELN('Item Number ', ITEMNUM); ,END; (* FOR *) ) )(* TEST CALL *) )TMPBOOL:= ROOMONPAGE(SKIP, REPORTCTRL.PHYSICAL, 0, TRUE); & &END; (* OF TESTREPORT *) # #PROCEDURE TESTRESPOND; &CONST )TYP)IF ESCTYPED THEN ,EXIT(TESTREPORT); ) )(* TEST CALL *) )INITREPORT(18, 20, 'Dummy Report', SCREEN); ) )FOR ITEMNUM:= 1 TO 50 DO ,BEGIN / /(* TEST CALL *) /IF NOT ROOMONPAGE(PRINT, 1, 1, FALSE) THEN 2 2IF ESCTYPED THEN 5EXIT(TESTREPORT) 2ELSMD, ' 18 data lines per page'); )SCREENMSG(2, 5, NULLCMD, ' 20 physical lines per page'); )SCREENMSG(2, 6, NULLCMD, ' the SCREEN for output.'); )SCREENMSG(2, 8, NULLCMD, '50 items are displayed a page at a time.'); )RESPOND(QUIET, TYPERET); t is the BANNER? ', BANNER) THEN .EXIT(TESTSTDSCREEN); +IF NOSTRG(5, 'What is the date (TODAY)? ', TODAY) THEN .EXIT(TESTSTDSCREEN); + +(* TEST CALL *) +STDSCREEN(BANNER); % +IF WANTSTOLEAVE THEN .EXIT(TESTSTDSCREEN); (UNTIL FALSE; %END; (* OF TESTSTDSCREEN *) # #PROCEDURE TESTSTRGDATE; %VAR (DATE *: DATEINT; (TMPSTRG *: STRING; % %FUNCTION GETNUM(LINENUM: INTEGER; STRG: STRING) .: INTEGER; (VAR +TMPINT -: INTEGER; (BEGIN (* GETNUM *) +IF NONUM(LINENUM, STRG, TMPINT) THEN .EXIT *TESTUNIT SG; ,18: TESTSOUNDBELL; ,19: TESTSTDSCREEN; ,20: TESTSTRGDATE; ,21: TESTVALIDDATE; ,END; (* CASE *) # UNTIL FALSE; #END. (* OF TESTUNIT *) # ; ,4: TESTEVINT; ,5: TESTEVALUATE; ,6: TESTFIRSTNON; ,7: TESTFMTDATE; ,8: TESTFMTNUM; ,9: TESTGETCHR; ,10: TESTJUSTIFY; ,11: TESTLOCATE; ,12: TESTLONGDIV; ,13: TESTMAKESTRG; ,14: TESTPROMPT; ,15: TESTREPORT; ,16: TESTRESPOND; ,17: TESTSCREENMRT REVISIONS YOU WISH TO TEST HERE. $* THEN RE-COMPILE TESTUNIT $*) # #BEGIN (* TESTUNIT *) & &NUMSELS:= 21; &REPEAT )STDSCREEN('Test General Utility Modules'); )DISPMENU; )CASE SELECTION OF ,1: TESTCHGLEN; ,2: TESTDATECOMPARE; ,3: TESTDELAY)SCREENMSG(MIDSCREEN, 8, NULLCMD, '18. SOUNDBELL'); )SCREENMSG(MIDSCREEN, 9, NULLCMD, '19. STDSCREEN'); )SCREENMSG(MIDSCREEN, 10, NULLCMD, '20. STRGDATE'); )SCREENMSG(MIDSCREEN, 11, NULLCMD, '21. VALIDDATE'); &END; (* OF DISPMENU *) # #(* $* INSE'); )SCREENMSG(MIDSCREEN, 4, NULLCMD, '14. PROMPT'); )SCREENMSG(MIDSCREEN, 5, NULLCMD, '15. Report Control Modules'); )SCREENMSG(MIDSCREEN, 6, NULLCMD, '16. RESPOND'); )SCREENMSG(MIDSCREEN, 7, NULLCMD, '17. SCREENMSG'); 9, NULLCMD, '8. FMTNUM'); )SCREENMSG(0, 10, NULLCMD, '9. GETCHR'); )SCREENMSG(0, 11, NULLCMD, '10. JUSTIFY'); )SCREENMSG(0, 12, NULLCMD, '11. LOCATE'); )SCREENMSG(MIDSCREEN, 2, NULLCMD, '12. LONGDIV'); )SCREENMSG(MIDSCREEN, 3, NULLCMD, '13. MAKESTRG3, NULLCMD, '2. DATECOMPARE'); )SCREENMSG(0, 4, NULLCMD, '3. DELAY'); )SCREENMSG(0, 5, NULLCMD, '4. EVALINT'); )SCREENMSG(0, 6, NULLCMD, '5. EVALUATE'); )SCREENMSG(0, 7, NULLCMD, '6. FIRSTNON'); )SCREENMSG(0, 8, NULLCMD, '7. FMTDATE'); )SCREENMSG(0, ) SCREENMSG(0, 6, CLRLINE, NULLSTRG); )UNTIL FALSE; &END; (* OF TESTVALIDDATE *) # #PROCEDURE DISPMENU; &VAR )MIDSCREEN +: INTEGER; &BEGIN (* DISPMENU *) )MIDSCREEN:= SCRCOLS DIV 2; )SCREENMSG(0, 2, NULLCMD, '1. CHGLEN'); # SCREENMSG(0, TEST CALL *) ,IF VALIDDATE(DATESTRG, DATE) THEN /TMPSTRG:= NULLSTRG ,ELSE /TMPSTRG:= ' not'; ,SCREENMSG(0, 6, CLRLINE, DATESTRG); ,WRITE(' is', TMPSTRG, ' a valid date.'); ) IF WANTSTOLEAVE THEN /EXIT(TESTVALIDDATE); RING; &BEGIN (* TESTVALIDDATE *) & STDSCREEN('Testing VALIDDATE'); )DISPPURPOSE( )'Validates a date string and converts it to packed format.'); )REPEAT ,IF NOSTRG(4, 'Date string (mmddyy) (DATESTRG)? ', DATESTRG) THEN /EXIT(TESTVALIDDATE); , ,(*NE, 'The date string (DATESTRG) is '); +WRITE(TMPSTRG); ( IF WANTSTOLEAVE THEN .EXIT(TESTSTRGDATE); ( CLEARLINES(5, 7); (UNTIL FALSE; %END; (* OF TESTSTRGDATE *) # #PROCEDURE TESTVALIDDATE; &VAR )DATE +: DATEINT; )DATESTRG, )TMPSTRG +: ST1DAY:= GETNUM(4, 'What is the DAY number? '); 1MONTH:= GETNUM(5, 'What is the MONTH number? '); 1YEAR:= GETNUM(6, 'What are the last two digits of the YEAR? '); .END; (* WITH *) + +(* TEST CALL *) +STRGDATE(DATE, TMPSTRG); + +SCREENMSG(0, 7, CLRLI(TESTSTRGDATE) +ELSE .GETNUM:= TMPINT; (END; (* OF GETNUM *) % %BEGIN (* TESTSTRGDATE *) (STDSCREEN('Testing STRGDATE'); (DISPPURPOSE('Convert a packed date to a string.'); (REPEAT +WITH DATE DO .BEGIN bbbbbbbbbbbbbbbbp@88ndGIJKLMNOPQRSTUVWXYZ[\]^X NDate attributes:צYear, month, day order (YMD)?  צDay, month, year order (DMY)?  צFull month name (FULLMON)? !Abbreviate month name (ABBRMON)? צFour-digit year (FULLYEfrom which direction (HOWJUST)?  צ&Which character to scan for (PADCHR)? String to scan (SRCSTRG)? צ4First non-matching character position (FIRSTNON) is  (STRG)?  Function value (EVALINT) is  צ'First non-numeric position (CURPOS) is  V צTesting FIRSTNONצ%Scan a string from the left or right.%Scan G)?  צ VALUE is  'First non-numeric position (CURPOS) is  \ צTesting EVALINT(Evaluate a numeric string as an INTEGER.String to evaluate nterval of time.צWait how long (DURATION)?  צWaiting for a count of  צ...צTesting EVALUATEצ,Evaluate a numeric string as a LONG INTEGER.צString to evaluate (STRɡ:צ is less than +yá9 is equal to +;צ is greater than + צ Testing DELAYDelay a small i between > and < below.><T צTesting DATECOMPARECompare two dates.+צ061581PצRight-hand date (RIGHTDATE) is +Left-hand date (LEFTDATE)? +*,.02468:<>@LDFHJLNPRhVXZ\^oR  צTesting CHGLENצChange the length of a string.PX String to change (STRG)? צNew length of STRG (NEWLEN)? * *צ(Resulting STRG isRz ۪Pצ9Type L(eft, R(ight, or C(enter, or Type [ESCAPE] to leaveצqlgCr`  (/"$&( 0   Your Choice?  ōڡ6D ܪP00 ڼۗT . ڪPצ+Type a character, or Type [ESCAPE] to leave@@צڝR ۪Pצ)Enter a number, or Type [ESCAPE] to leave4ǀ צ40/ 0 0leaveP/ڪP//צEXIT vڦ%Enter alternate characters (ALTCHR)? ۓ9K š$KK/T |۪Pצ&Type Y or N, or Type [ESCAPE] to leaveȡ,ٛ ٛٛ 4 DتPצ** R$(Type [RETURN], or Type [ESCAPE] to leave<ȡצ ۪Pצ&Enter a string, or Enter EXIT to AR)?  צTesting FMTDATE:Format a numeric string as a date in a variety of formats.0Delimiter between month, day, year (DATEDELIM)? á-צDate string (DATESTRG)? , צFormatted string (FMTSTRG) is , >Numeric Attributes:Insert commas (COMMAS)?  "Insert a decimal point (DECIMAL)?  Insert a dollar sign (DOLLAR)? á ̀ צ&Number of decimal places (NUMPLACES)?  ! צ&Minimum number of digits (MINDIGITS)?  ! צ"Maximum response length (RSPLEN)?  ! !Xʀ  /  /Pצ"Response is beteen for a response of the specified type and length./צP! !0Delimiter between month, day, year (DATEDELIM)? á-  ! צ#Background character (BACKGROUND)? !character into a one byte string.צCharacter to use (CH)?  Resulting string (STRG) is צ (Length is  )  XצTesting PROMPTPXצEPrompt on the scr)? צ1Are only alternate characters allowed (ALTONLY)? 6Suppress echoing of the terminated response (NOECHO)?  (Disable ESCAPE from the prompt (NOESC)?  :צTesting MAKESTRGצ(Turn a   צQuotient (LQUOTIENT) is  צRemainder (LREMDR) is  ٦!Is the desired response NUMERIC?  צ*Is the desired response a date (STDDATEtes (DISPLACE)? ײ   צTesting LOCATEצ'Locate an entry on a "page" of entries.JצTesting LONGDIVDoes LONG INTEGER division.צ DIVIDEND? ;צ DIVISOR? ;     Are entries BLOCKED? ײEntry length (ENTLEN)? ײ Page length (PAGELEN)? ײ #Number of reserved bytes (RESRVD)? ײ +Size of displacement, in by between > and < below. >-< L Entry number (ENTNUM)? ײ  צPage number (PAGENUM) is   צPosition (POSNUM) is String to justify (SRCSTRG)? צWhich direction (HOWJUST)?  Background character (PADCHR)? á צ-Desired length of justified string (NEWLEN)?  - 4Resulting string (DSTSTRG) is (WITHBELLS)? צ'String of valid characters (VALIDCHR)?  š"Px .צTesting JUSTIFY*Left-, Center-, or Right-Justify a string.צTRUEP צFALSEPASCII value of RSPCHR is  ; ESCTYPED is צTesting GETCHRצ#Gets a character from the keyboard.Number of delays (NUMDELAYS)?  Sound bells צJustification (HOWJUST)?   #Maximum number of digits (MAXLEN)?  y e 1  Formatted string (FMTSTRG) is 1  $Format and justify a numeric string.צ#Background character (BACKGROUND)? á &Number of decimal places (NUMPLACES)?  &Minimum number of digits (MINDIGITS)?  צUnformatted string (RAWSTRG)? צ*Fixed dollar sign or parentheses (FIXED)?  צ"Is this a signed number (SIGNED)? צInsert parentheses (PARENS)?  "Trailing minus sign (TRAILMINUS)? צTesting FMTNUMצween > and < below.><` !צDUMMY REPORT HEADING LINEGצPage:  ġצ #צTesting Report ControlsThis test procedure uses:צ 18 data lines per page 20 physical lines per pageצ the SCREEN for output.(50 items are displayed a page at a time.צ(Type [RETURN], or Type [ESCAPE] to leave" Dummy ReportN^蠗rnjfb^ZV R!N"J$F%B&>':(6*2*\ZXVTRPNLJHFDB@><:86403"L@ H n ,PP .@ L!"#$%L&&&'.((,)R)))V+t Control Modulesצ 16. RESPONDצ 17. SCREENMSGצ 18. SOUNDBELL צ 19. STDSCREEN צ 20. STRGDATE 21. VALIDDATE+ΧצTest General Utility Modules+ T~zvrnjfb^ZV R!N"J$F%B&>':(6*2*\ZXVTRPNLJHFDB@><:86403"L@ H n ,PP .@ L!"#$%L&&&'.((,)15. Report Control Modulesצ 16. RESPONDצ 17. SCREENMSGצ 18. SOUNDBELL צ 19. STDSCREEN צ 20. STRGDATE 21. VALIDDATE+ΧצTest General Utility Modules+ T~zvצ2. DATECOMPARE3. DELAYצ 4. EVALINT 5. EVALUATE 6. FIRSTNON 7. FMTDATE צ 8. FMTNUM צ 9. GETCHR צ 10. JUSTIFY צ 11. LOCATE 12. LONGDIV 13. MAKESTRGצ 14. PROMPTates a date string and converts it to packed format.צ!Date string (mmddyy) (DATESTRG)? +*+ תP צ notP+צ isצ a valid date.*צ *Pצ 1. CHGLENצWhat is the DAY number? )צWhat is the MONTH number? )  צ*What are the last two digits of the YEAR? )cThe date string (DATESTRG) is (T (צTesting VALIDDATE9ValidREENצDisplay a standard screen.What is the BANNER? 'What is the date (TODAY)? ק''dR'ڪP. (.T")צTesting STRGDATEצ"Convert a packed date to a string.*,.02468:<>@QDZHJLNZWhat is the MESSAGE? %%X%צTesting SOUNDBELL...צSounds a bell.צNumber of bells?  &ȡ,A x&צTesting STDSCOS)?  %9Type N(ullcmd, L(ine, S(creen, or Type [ESCAPE] to leave.Clearing option (COMMAND)? PPצ%a\WLsP  "$&(02468:<>@MDFH_LNPRTVXZ\^`|dfhjl~What is the MESSAGE? $6T $צTesting SCREENMSG Display a message on the screen. Beginning screen column (XPOS)?  %Screen line (YPuiet, E(rror, W(arning, A(ttention, or Type [ESCAPE] to leave. What kind of message (MSGKIND)? ""${vAwn   <$&(*,>2ȡR "# Item Number  h "צTesting RESPOND/Display a message at a standard screen locationצand wait for a character.$EType Q(_abcdefghijklm 'CREATING RECORD AREA'); 5FOR TMPINT:= FINALHDR+ 1 TO LASTBLK DO 8BEGIN ;BLKIO(STORE, NEWVAR, PNEWPARS^.FHDR.BUF^, 1, TMPINT); 9 TESTERR; 8END; (* FOR *) 2END; (* IF *) /CLOSE(NEWVAR, LOCK); & END; (* WITH *) &END; (* BUILDFILE *) # #BEGI/SCREENMSG(0, 14, NULLCMD, 'CREATING HEADER AREA'); /TESTERR; /FOR TMPINT:= 0 TO FINALHDR DO 2BEGIN 5BLKIO(STORE, NEWVAR, PNEWPARS^.FHDR.BUF^, 1, TMPINT); / TESTERR; / END; (* FOR *) /IF MAXALLOWED> 0 THEN 2BEGIN 5SCREENMSG(0, 15, NULLCMD,/BLKIO(STORE, NEWVAR, TMPBUF, 1, LASTBLK); /TESTERR; /BLKIO(RETRIEVE, NEWVAR, TMPBUF, 1, LASTBLK- 1); /TESTERR; /IF EOF(NEWVAR) THEN 2BEGIN 5RESPOND(ERROR, 'NOT ENOUGH ROOM'); 5CLOSE(NEWVAR); 5ERRNUM:= -1; 5EXIT(BUILDFILE); / END; (* IF *) / KLEN, 0); /PNEWPARS^.FHDR.PARS^:= NEWHDR; /SCREENMSG(0, 13, NULLCMD, CONCAT('CREATING ', FILENAME)); /(*$I-*) /REWRITE(NEWVAR, FILENAME); /(*$I+*) /ERRNUM:= IORESULT; /TESTERR; / /(* TEST FOR ENOUGH ROOM *) ION,  0 THEN /BEGIN 2STR(ERRNUM, TMPSTRG); 2RESPOND(ATTENT,VALID:= FALSE; ,SCREENMSG(0, 4, NULLCMD, 'Maximum number of records? '); ,PROMPT(27, 4, 5, NULLSTRG, TMPSTRG, [NUMERIC]); ,IF ESCTYPED THEN /EXIT(PROGRAM); ,EVALUATE(TMPSTRG, TMPLONG, TMPINT); ,IF TMPINT> 32767 THEN /RESPOND(ERROR, '? MUST BE FROMI+*) 2ERRNUM:= IORESULT; 2 2IF ERRNUM> 0 THEN 5RESPOND(ERROR, '? CAN''T OPEN ') 2ELSE 5CLOSE(NEWVAR); /END; (* IF *) )UNTIL ERRNUM= 0; &END; (* OF GETFILENAME *) # #PROCEDURE GETMAX; &BEGIN (* GETMAX *) &(* ASSIGN MAXALLOWED *) )REPEAT ); ,PROMPT(3, 3, 40, NULLSTRG, FILENAME, []); ,IF FILENAME= NULLSTRG THEN 2EXIT(PROGRAM); ,TMPSTRG:= FILENAME; ,IF POS(':', FILENAME)>= LENGTH(FILENAME) THEN /RESPOND(ERROR, '? NO FILENAME') ,ELSE /BEGIN 2(*$I-*) 2REWRITE(NEWVAR, FILENAME); 2(*$ (: INTEGER; &TMPLONG (: LONG; &NEWHDR (: HDRPARS; &NEWVAR (: FILEVAR; # FILENAME, &TMPSTRG (: STRING; # TMPBUF (: CHARBLK; # #PROCEDURE GETFILENAME; &BEGIN (* GETFILENAME *) )REPEAT ,SCREENMSG(0, 2, NULLCMD, 'Name of file to create? '(*$S++*)  (*$V-*)  PROGRAM CREATEFILE; #(* $* CREATES A FILE BASED ON USER INTERACTION $* $*) #USES &APPLESTUFF, &GENUTIL, &FILEACCESS; & #VAR &PNEWPARS (: PFILEPARS; &VALID (: BOOLEAN; &ADDLBLKS, &FINALHDR, &LASTBLK, &TMPINT, &TMPINT2N (* CREATEFILE *) # REPEAT )STDSCREEN('CREATE FILE'); )GETFILENAME; )WITH NEWHDR DO ,BEGIN /ACTHDR:= -1; /LASTINBLK:= 0; /NUMINBLK:= 0; /RECLEN:= 0; /STATMAP:= FALSE; /BLOCKED:= FALSE; /DISPLACE:= 500; , /GETMAX; /IF MAXALLOWED> 0 THEN 2BEGIN 5(* ASSIGN RECORD LENGTH *) 5REPEAT 8VALID:= FALSE; 8SCREENMSG(0, 5, NULLCMD, 'Record length (in bytes)? '); 8PROMPT(26, 5, 5, NULLSTRG, TMPSTRG, [NUMERIC]); 8IF ESCTYPED THEN ;EXIT(PROGRAM); 8EVALUATE(TMPSTRG, TMPLONG, TMPINT); 8IF (TMPLOnpqrsbbbbbbbbbbbbbbbbx@,88nd*CREATEFI 2SCREENMSG(0, 22, NULLCMD, >CONCAT(FILENAME, ' CANCELLED')) /ELSE / BUILDFILE; / /IF ERRNUM= 0 THEN 2RESPOND(ATTENTION, 'Type [RETURN] '); ,END; (* WITH *) # UNTIL FALSE; #END. (* CREATEFILE *) #  LKS; 5GOTOXY(0, 11); 5WRITELN('AND ', LASTBLK- FINALHDR, @' block(s) for records...'); , END; (* IF *) , ,(* PROMPT TO INSERT DISKETTE IN DRIVE *) /RESPOND(ATTENTION, 1'Prepare destination volume '); , IF ESCTYPED THEN FINALHDR+ 1, ' header block(s)'); /IF MAXALLOWED> 0 THEN 2BEGIN 5LOCATE(BLOCKED, MAXALLOWED, RECLEN, BLKLEN, 0, >(FINALHDR+ 1)* BLKLEN, >LASTBLK, TMPINT); 5LOCATE(FALSE, RECLEN, 1, BLKLEN, 0, TMPINT- 1, >ADDLBLKS, TMPINT); 5LASTBLK:= LASTBLK+ ADDLB; (* IF *) , /IF MAXALLOWED= 0 THEN 2STATMAP:= FALSE; /(* CREATE HEADER BLOCKS *) /IF STATMAP THEN 2LOCATE(FALSE, MAXALLOWED, 1, BLKLEN* 8, 12* 8, DISPLACE* 8, ;FINALHDR, TMPINT) /ELSE 2FINALHDR:= 0; /GOTOXY(0, 10); /WRITELN('READY TO CREATE ', 8PROMPT(24, 8, 3, NULLSTRG, TMPSTRG, [NUMERIC]); 8IF ESCTYPED THEN ;EXIT(PROGRAM); 8TMPINT:= EVALINT(TMPSTRG, TMPINT2); 8IF (TMPINT> 500) THEN ;RESPOND(ERROR, '? MUST BE FROM 0 TO 500') 8ELSE ;VALID:= TRUE; 5UNTIL VALID; 5DISPLACE:= TMPINT; 2END'N', 'n', ESC]); ;IF ESCTYPED THEN >EXIT(PROGRAM); ;WRITE(RSPCHR); ;BLOCKED:= (RSPCHR in ['Y', 'y']); 5 END; (* IF *) 5 5(* ASSIGN DISPLACEMENT *) 5REPEAT 8VALID:= FALSE; 8SCREENMSG(0, 8, NULLCMD, '1st block displacement? '); Y', 'y', 'N', 'n', ESC]); 5IF ESCTYPED THEN 8EXIT(PROGRAM); 5WRITE(RSPCHR); 5STATMAP:= (RSPCHR in ['Y', 'y']); 2 5IF RECLEN<= 512 THEN 8BEGIN ;(* ASSIGN BLOCKED *) ;SCREENMSG(0, 7, NULLCMD, 'Are records blocked? '); ;GETCHR(-1, FALSE, ['Y', 'y', NG< 1) OR (TMPINT> 32767) THEN ;RESPOND(ERROR, '? MUST BE FROM 1 TO 32767') 8ELSE ;VALID:= TRUE; 5UNTIL VALID; 5RECLEN:= TRUNC(TMPLONG); 5 5(* ASSIGN STATMAP *) 5SCREENMSG(0, 6, NULLCMD, @ 'Are statuses to be maintained? '); 5GETCHR(-1, FALSE, ['Name of file to create? (צc cׯ:cPצ:ccġ ? NO FILENAME4c"  š ? CAN'T OPEN  á צMaximum number of records? צ:ǀ :  (*$S++*)  (*$V-*)  PROGRAM LISTSTATUS; #(* $* LISTS FILE STATUS $* $*) #USES &APPLESTUFF, &GENUTIL, &FILEACCESS; & #VAR &PFPARS (: PFILEPARS; # TMPSTATUS (: RECSTATUS; &RECNUM, &TMPINT (: INTEGER; &TMPLONG (: LONG; &FVAR (: FILEtvwxyz{|}~N^ƣ5nC,l4l š צ? MUST BE FROM 0 TO 500 á    צREADY TO CREATE  צ header block(s)š|    AND   block(s) for records...Prepare destination volume -cP CANCELLEDZ áצType [RETURN] צ:ǀ : š צ? MUST BE FROM 0 TO 500 á    צREADY TO CREATE  צ header block(s)š| e maintained? @@ȡqAre records blocked? @@1st block displacement? צ CREATE FILE šצRecord length (in bytes)? ץ:ǀ :  ō"? MUST BE FROM 1 TO 32767 צAre statuses to b"  'NOT ENOUGH ROOM צCREATING HEADER AREAȡ š>CREATING RECORD AREAȡ #hZ 6:  š"צ? MUST BE FROM 0 TO 32767  šS :P צERROR :Vצ HAS OCCURRED.dfb    צ CREATING cYcVAR; &FILENAME, &TMPSTRG (: STRING; # PFREC (: PCHARBLK; # #PROCEDURE FINISHUP; &BEGIN (* FINISHUP *) )WRITELN('FAREWELL...'); )CLOSE(FVAR, LOCK); )EXIT(PROGRAM); &END; (* OF FINISHUP *) # #PROCEDURE WRBOOL(BOOL: BOOLEAN); &BEGIN (* WRBOOL *) & IF BOOL THEN ,WRITELN('TRUE') )ELSE ,WRITELN('FALSE'); &END; (* OF WRBOOL *) # #PROCEDURE CHECKRECS; &BEGIN (* CHECKRECS *) & )WHILE NOT ESCTYPED DO ,BEGIN /SCREENMSG(0, 23, CLRLINE, 'Read which Record number? '); /PROMPT(26, 23, 5, NULISTSTAT /SCREENMSG(20, 18, NULLCMD, 'NUMHDRBLKS: '); /WRITELN(NUMHDRBLKS); , WRITELN(' LASTBLK: ', LASTBLK); ,END; (* WITH *) & CHECKRECS; &UNTIL FALSE; #END. (* LISTSTATUS *)  NFILE); /WRITELN('RECSPERBLK: ', RECSPERBLK); /WRITELN(' CURRECNUM: ', CURRECNUM); /SCREENMSG(20, 16, NULLCMD, ' CURRECBLK: '); /WRITELN(CURRECBLK); /WRITELN(' CURHDRBLK: ', CURHDRBLK); /WRITELN('NUMRECBLKS: ', NUMRECBLKS); (* WITH *) /WRITE(' HDRPUT: '); /WRBOOL(HDRPUT); /SCREENMSG(20, 12, NULLCMD, ' RECPUT: '); /WRBOOL(RECPUT); /WRITELN('LASTACTHDR: ', LASTACTHDR); /WRITELN('LASTINFILE: ', LASTINFILE); /SCREENMSG(20, 14, NULLCMD, ' NUMINFILE: '); /WRITELN(NUMIMAP: '); 5WRBOOL(STATMAP); 5WRITE(' BLOCKED: '); 5WRBOOL(BLOCKED); 5WRITELN(' DISPLACE: ', DISPLACE); 5WRITELN(' ACTHDR: ', ACTHDR); 5WRITELN(' LASTINBLK: ', LASTINBLK); 5SCREENMSG(20, 11, NULLCMD, ' NUMINBLK: '); 5WRITELN(NUMINBLK); 2END; 2IF ERRNUM> 0 THEN 5RESPOND(ERROR, '?Can''t Open'); ) END; (* IF *) )UNTIL ERRNUM= 0; )WITH PFPARS^ DO ,BEGIN /WITH FHDR.PARS^ DO 2BEGIN 5GOTOXY(0, 5); 5WRITELN(' RECLEN: ', RECLEN); 5WRITELN('MAXALLOWED: ', MAXALLOWED); 5WRITE(' STATe of file to list? '); ,PROMPT(3, 3, 40, NULLSTRG, FILENAME, []); ,IF ESCTYPED THEN /EXIT(PROGRAM); ,IF POS(':', FILENAME)>= LENGTH(FILENAME) THEN /RESPOND(ERROR, 'No Filename') ,ELSE , BEGIN 2OPENFILE(FVAR, PFPARS, FILENAME); D, P'and non-readable'); >END; (* IF *) 2 END; (* IF *) 2END; (* IF *) # END; (* WHILE *) # CLOSE(FVAR); #END; (* CHECKRECS *) # #BEGIN (* LISTSTATUS *) &REPEAT )STDSCREEN('List File Status'); )REPEAT ,SCREENMSG(0, 2, NULLCMD, 'NamEENMSG(0, 22, clrline, PCONCAT(TMPSTRG, 'Active')) AELSE DSCREENMSG(0, 22, clrline, PCONCAT(TMPSTRG, 'Inactive')); AGETREC(FVAR, PFPARS, RECNUM, PFREC); AIF ERRNUM= 0 THEN DSCREENMSG(26, 22, NULLCMD, 'and Readable') AELSE DSCREENMSG(26, 22, NULLCM;ERRNUM:= 0; ;TMPSTATUS:= STATUSOF(FVAR, PFPARS, RECNUM); ;IF ERRNUM> 0 THEN >RESPOND(ERROR, 'Error retrieving status') ;ELSE ; BEGIN ASTR(RECNUM, TMPSTRG); ; TMPSTRG:= CONCAT('Record ', TMPSTRG, ' is '); > IF TMPSTATUS= ACTIVE THEN DSCRLLSTRG, TMPSTRG, [NUMERIC]); /IF NOT ESCTYPED THEN 2BEGIN 5EVALUATE(TMPSTRG, TMPLONG, TMPINT); 5IF (TMPLONG< 1) OR :(TMPLONG> PFPARS^.FHDR.PARS^.MAXALLOWED) THEN 8RESPOND(ERROR, 'Out of range') 5ELSE 8BEGIN ;RECNUM:= TRUNC(TMPLONG); bbbbbbbbbbbbbbbbx@,88ndN^ƣ צ RECSPERBLK:   CURRECNUM:   CURRECBLK:  צ CURHDRBLK:  צ NUMRECBLKS:   NUMHDRBLKS:   LASTBLK:   T4 >djb   LASTINFILE:  צ NUMINFILE:  צ RECSPERBLK:   CURRECNUM:   CURRECBLK:  צ CURHDRBLK:  צ NUMRECBLKS:   NUMHDRB LASTINBLK:   צ NUMINBLK:  צ HDRPUT:  צ RECPUT:  LASTACTHDR:   LASTINFILE:  צ NUMINFILE:  RECLEN:  צ MAXALLOWED:   STATMAP:  BLOCKED:  DISPLACE:   צ ACTHDR:  -readable  \ 1ΧצList File StatusName of file to list? (צZ :ץZZġצ No Filename# Z š ?Can't Open áꫂ ͼ   š צError retrieving status1P 1צRecord 1W is [Pá%1PצActiveV%1PInactiveX  á and Readableצand non FAREWELL... 4ءצTRUEצFALSE>Read which Record number? צ1ǀ 1   צ Out of range  (*$S++*)  (*$V-*)  PROGRAM INVENTORY; #(* $* INVENTORY.TEXT $* MAINTAINS AN INVENTORY FILE. $* $* ANY NUMBER OF SEPARATE INVENTORY FILES MAY EXIST. $* THE PROGRAM THINKS THAT ANY FILE WITH A '.INV' EXTENSION IS A VALID $* DATA FILNAME, ' not found ')) ) ELSE /SCREENMSG(0, 23, CLRLINE, NULLSTRG); )UNTIL ERRNUM= 0; ) )BUILDTREE; ) )MENUSET:= ['1'..'7', ESC]; & GETGLOBALS(INVVAR, PINVPARS, PINVGLOB.PBUF); )TESTFATAL(GETGLBERR); )STRGDATE(PINVGLOB.PGLOB^.TODAYINT, TODAY);CREENMSG(0, 23, NULLCMD, 'Inventory Name? '); ,PROMPT(16, 23, 40, NULLSTRG, FILENAME, []); ,IF FILENAME= NULLSTRG THEN /EXIT(PROGRAM); ,ERRNUM:= 0; ,OPENFILE(INVVAR, PINVPARS, CONCAT(FILENAME, '.INV')); ,IF ERRNUM> 0 THEN /RESPOND(ERROR, CONCAT(FILE2INSERTKEY(INVTREE, INVKEY); 2FINDNEXT(INVVAR, PINVPARS, RECNUM, ACTIVE); / TESTFATAL(FNDNXTERR); /END; (* WHILE *) & END; (* OF BUILDTREE *) & &BEGIN (* INITIALIZE *) )BANNER:= 'Inventory File Maintenance'; )STDSCREEN(BANNER); ) )REPEAT ,S ,OPENTREE(INVTREE, 11, 5); ,RECNUM:= 0; ,FINDNEXT(INVVAR, PINVPARS, RECNUM, ACTIVE); ,TESTFATAL(FNDNXTERR); ,WHILE RECNUM> 0 DO /BEGIN 2GETREC(INVVAR, PINVPARS, RECNUM, PINVREC.PBUF); 2TESTFATAL(GETRECERR); 2BUILDKEY; TMPSTRG[1], INVKEY[4], 6); /INVKEY[10]:= CHR(RECNUM DIV 256); /INVKEY[11]:= CHR(RECNUM MOD 256); ,END; (* WITH *) &END; (* OF BUILDKEY *) # #PROCEDURE INITIALIZE; &(* '* PROGRAM INITIALIZATION '* '*) &PROCEDURE BUILDTREE; )BEGIN (* BUILDTREE *)Y '* ITEMTYPE+ 1ST 6 CHARACTERS OF ITEMDESC+ RECNUM '* '*) &VAR )TMPSTRG +: STRING[6]; &BEGIN (* BUILDKEY *) & WITH PINVREC.PREC^ DO ,BEGIN /JUSTIFY(ITEMTYPE, INVKEY, LEFT, SPACE, 11); /JUSTIFY(ITEMDESC, TMPSTRG, LEFT, SPACE, 6); /MOVELEFT(2PUTRECERR: ERRORMSG:= 'CAN''T WRITE RECORD'; 2STATOFERR: ERRORMSG:= 'CAN''T GET RECORD STATUS'; 2END; (* CASE *) /RESPOND(ERROR, ERRORMSG); /EXIT(PROGRAM); & END; (* IF *) &END; (* OF TESTFATAL *) # #PROCEDURE BUILDKEY; &(* '* BUILD THE KEFORCEERR: ERRORMSG:= 'CAN''T UPDATE FILE'; 2GETGLBERR: ERRORMSG:= 'CAN''T GET ACTIVITY DATE'; 2GETRECERR: ERRORMSG:= 'CAN''T READ RECORD'; 2OPENERR: ERRORMSG:= 'CAN''T OPEN FILE'; 2PUTHDRERR: ERRORMSG:= 'CAN''T WRITE HEADER'; * TESTFATAL *) & IF ERRNUM> 0 THEN ) BEGIN /CASE ERRORKIND OF 2BLKIOERR: ERRORMSG:= 'CAN''T PROCESS BLOCK'; 2CHGHDRERR: ERRORMSG:= 'CAN''T UPDATE HEADER'; 2CLOSEERR: ERRORMSG:= 'CAN''T CLOSE FILE'; 2FNDNXTERR: ERRORMSG:= 'CAN''T SCAN HEADER'; 2; &FILENAME (: STRING[40]; &TMPSTRG (: STRING[25]; &BANNER (: STRING[26]; &MENUSET (: CHARSET; &TMPREC (: INVREC; &INVTREE (: TREEPARS; &INVVAR (: FILEVAR; # #PROCEDURE TESTFATAL(ERRORKIND: ERRORTYPE); &VAR )ERRORMSG +: STRING; &BEGIN (02: (PGLOB: ^INVGLOB); *END; (* RECORD *) &PINVREC (: RECORD -CASE INTEGER OF 01: (PBUF: PCHARBLK); 02: (PREC: ^INVREC); *END; (* RECORD *) &ADDING, &FIRSTFIELD (: BOOLEAN; &TMPINT, &RECNUM, &PREVRECNUM (: INTEGER; # INVKEY (: STRING[11]ORD -ITEMTYPE: STRING[3]; -ITEMDESC: STRING[25]; *END; (* RECORD *) # # INVGLOB (= PACKED RECORD -TODAYINT: DATEINT; -END; (* RECORD *) #VAR &PINVPARS (: PFILEPARS; &PINVGLOB (: RECORD -CASE INTEGER OF 01: (PBUF: PCHARBLK); . $* $*) #USES &APPLESTUFF, &GENUTIL, &FILEACCESS, &BTREE; & #TYPE &ERRORTYPE (= (BLKIOERR, +CHGHDRERR, +CLOSEERR, +FNDNXTERR, +FORCEERR, +GETGLBERR, +GETRECERR, +OPENERR, +PUTHDRERR, +PUTRECERR, +STATOFERR); & &INVREC (= PACKED RECE. $* $* TYPE 'PUTLIB:VIDEOTAPE' IN RESPONSE TO THE 'INVENTORY NAME?' PROMPT $* TO TEST THIS PROGRAM. $* $* TO RECREATE THE ABOVE FILE, $* EXECUTE 'CREATEFILE' AND TYPE 'PUTLIB:VIDEOTAPES.INV' IN RESPONSE $* TO THE 'FILENAME?' PROMPT &END; (* OF INITIALIZE *) # #PROCEDURE TERMINATE; &(* & * PROGRAM TERMINATION '* '*) &BEGIN (* TERMINATE *) )SCREENMSG(0, 0, CLRSCREEN, NULLSTRG); )CLOSEFILE(INVVAR, PINVPARS); )TESTFATAL(CLOSEERR); )EXIT(PROGRAM); &END; (* OF TERMINATE *) & #PROCEDURE SHOWREC; &BEGIN (* SHOWREC *) )SCREENMSG(0, 2, NULLCMD, 'Record Number: '); )WRITE(RECNUM); )GETREC(INVVAR, PINVPARS, RECNUM, PINVREC.PBUF); )TESTFATAL(GETRECERR); )SCREENMSG(4, 3, NULLCMD, 'Type: '); )IF NOT ADDING THEN ,WRITELN(PINIF RECNUM= 0 THEN /EXIT(CHANGERECS); ,TMPREC:= PINVREC.PREC^; ,ALTCHR:= ['Y', 'y', 'N', 'n']; ,RESPOND(QUIET, 'Any changes? '); ,ALTCHR:= NULLSET; ,IF RSPCHR IN ['Y', 'y'] THEN , BEGIN 2GETFIELDS; 2IF NOT ESCTYPED THEN 5BEGIN 8IF PINVREC.PREC^DREC; # END; (* OF GETRECNUM *) # #PROCEDURE CHANGERECS; &(* '* CHANGES RECORDS IN THE INVENTORY FILE BASED ON USER INTERACTION '* '*) &VAR )PREVKEY +: STRING[11]; &BEGIN (* CHANGERECS *) )STDSCREEN('Change Records'); )REPEAT ,GETRECNUM; ,,ELSE /BEGIN 2TMPSTATUS:= STATUSOF(INVVAR, PINVPARS, RECNUM); 2TESTFATAL(STATOFERR); 2IF TMPSTATUS= INACTIVE THEN 5RESPOND(ERROR, 'Record is not active ') 2ELSE 5BEGIN 8VALIDREC:= TRUE; 8SHOWREC; 5END; (* IF *) ) END; (* IF *) )UNTIL VALI NULLSTRG); ,RECNUM:= EVALINT(TMPSTRG, TMPINT); ,IF RECNUM= 0 THEN /BEGIN 2FORCEWRITE(INVVAR, PINVPARS); , TESTFATAL(FORCEERR); 2EXIT(GETRECNUM); /END; (* IF *) ,IF RECNUM> PINVPARS^.LASTINFILE THEN /RESPOND(ERROR, 'Record does not exist ') INTEGER; &BEGIN (* GETRECNUM *) )FOR LINENUM:= 2 TO 4 DO /SCREENMSG(0, LINENUM, CLRLINE, NULLSTRG); )SCREENMSG(0, 2, NULLCMD, 'Record Number? '); )VALIDREC:= FALSE; )REPEAT ,PROMPT(15, 2, 5, NULLSTRG, TMPSTRG, [NUMERIC]); ,SCREENMSG(0, 22, CLRLINE,TAL(FORCEERR); >EXIT(ADDRECS); ;END 5END 2ELSE 5SCREENMSG(0, 22, NULLCMD, 'Add cancelled'); ) END; (* IF *) )UNTIL FALSE; &END; (* OF ADDRECS *) #PROCEDURE GETRECNUM; &VAR )VALIDREC +: BOOLEAN; )TMPSTATUS +: RECSTATUS; & LINENUM +: 8BUILDKEY; 8INSERTKEY(INVTREE, INVKEY); 8SCREENMSG(0, 22, NULLCMD, 'Record added'); 8IF PINVPARS^.NUMINFILE= PINVPARS^.FHDR.PARS^.MAXALLOWED :THEN ;BEGIN >RESPOND(WARNING, HCONCAT(FILENAME, ' is now full')); >FORCEWRITE(INVVAR, PINVPARS); >TESTFATCHR:= NULLSET; 2IF RSPCHR IN ['Y', 'y', RET] THEN 5BEGIN 8PINVREC.PREC^:= TMPREC; 8PUTREC(INVVAR, PINVPARS, FALSE); 8TESTFATAL(PUTRECERR); 8PREVRECNUM:= RECNUM; 8CHANGEHDR(INVVAR, PINVPARS, RECNUM, ACTIVE, FALSE); 8TESTFATAL(CHGHDRERR); , INACTIVE); ,TESTFATAL(FNDNXTERR); ,SHOWREC; ,GETFIELDS; ,IF ESCTYPED THEN /BEGIN 2IF FIRSTFIELD THEN 5EXIT(ADDRECS); , END ,ELSE , BEGIN 2(* CONFIRM THE ADD *) 2ALTCHR:= ['Y', 'y', 'N', 'n']; 2RESPOND(QUIET, 'Type [RETURN] to Add'); 2AL USER INTERACTION '* '*) &BEGIN (* ADDRECS *) )ADDING:= TRUE; )STDSCREEN('Add Records'); )PREVRECNUM:= 0; )WITH TMPREC DO ,BEGIN /ITEMTYPE:= ''; /ITEMDESC:= ''; ,END; (* WITH *) )REPEAT ,RECNUM:= PREVRECNUM; ,FINDNEXT(INVVAR, PINVPARS, RECNUM5FORCEWRITE(INVVAR, PINVPARS); 5TESTFATAL(FORCEERR); , END; (* IF *) ,END )ELSE ,BEGIN /FIRSTFIELD:= FALSE; /GETDESCR; & END; (* IF *) &END; (* OF GETFIELDS *) & #PROCEDURE ADDRECS; &(* '* ADDS RECORDS TO THE INVENTORY FILE BASED ONS; &VAR )LINENUM +: INTEGER; &BEGIN (* GETFIELDS *) )FIRSTFIELD:= TRUE; )GETTYPE; )SCREENMSG(0, 22, CLRLINE, NULLSTRG); )IF ESCTYPED THEN ,BEGIN /IF ADDING THEN 2BEGIN 5FOR LINENUM:= 2 TO 4 DO 8SCREENMSG(0, LINENUM, CLRLINE, NULLSTRG); HEN ,TMPREC.ITEMTYPE:= TMPSTRG; &END; (* OF GETTYPE *) # #PROCEDURE GETDESCR; &BEGIN (* GETDESCR *) )PROMPT(10, 4, 25, TMPREC.ITEMDESC, TMPSTRG, []); )IF NOT ESCTYPED THEN ,TMPREC.ITEMDESC:= TMPSTRG; &END; (* OF GETDESCR *) # #PROCEDURE GETFIELDVREC.PREC^.ITEMTYPE); )SCREENMSG(3, 4, NULLCMD, 'Descr: '); )IF NOT ADDING THEN ,WRITELN(PINVREC.PREC^.ITEMDESC); &END; (* OF SHOWREC *) # #PROCEDURE GETTYPE; &BEGIN (* GETTYPE *) )PROMPT(10, 3, 3, TMPREC.ITEMTYPE, TMPSTRG, []); )IF NOT ESCTYPED T<> TMPREC THEN ;BEGIN >BUILDKEY; >DELETEKEY(INVTREE, INVKEY); >PINVREC.PREC^:= TMPREC; >PUTREC(INVVAR, PINVPARS, FALSE); >TESTFATAL(PUTRECERR); >BUILDKEY; >INSERTKEY(INVTREE, INVKEY); >SCREENMSG(0, 22, NULLCMD, 'Record changed'); ;END 8ELSE ;SCREENMSG(0, 22, NULLCMD, '(No changes made)'); / END; (* IF *) /END; (* IF *) )UNTIL FALSE; &END; (* OF CHANGERECS *) #PROCEDURE INSPECT; &(* '* LISTS INDIVIDUAL RECORDS IN THE INVENTORY FILE '* '*) &BEGIN (* INSPECT *) )STDSCREEN('InspTFATAL(FNDNXTERR); ,END; (* WHILE *) & TMPBOOL:= ROOMONPAGE(SKIP, REPORTCTRL.PHYSICAL, 0, TRUE); &END; (* OF DISPRECS *) # #PROCEDURE PRINTRECS; &VAR )FOUND, )TMPBOOL +: BOOLEAN; )TMPSTRG +: STRING; & &PROCEDURE PRINTHDR; )VAR ,TMPINT .: BEGIN 5GOTOXY(0, LINESONPAGE- 1); 5WRITE(RECNUM); 5GOTOXY(8, LINESONPAGE- 1); 5WRITE(PINVREC.PREC^.ITEMTYPE); 5GOTOXY(14, LINESONPAGE- 1); 5WRITE(PINVREC.PREC^.ITEMDESC); , END; (* IF *) /FINDNEXT(INVVAR, PINVPARS, RECNUM, ACTIVE); , TES)FINDNEXT(INVVAR, PINVPARS, RECNUM, ACTIVE); )TESTFATAL(FNDNXTERR); )WHILE RECNUM> 0 DO ,BEGIN , GETREC(INVVAR, PINVPARS, RECNUM, PINVREC.PBUF); /TESTFATAL(GETRECERR); /PAGEOVERFLOW(SKIP, 1, 1); /PAGEOVERFLOW(PRINT, 1, 1); /WITH REPORTCTRL DO /)BEGIN (* PAGEOVERFLOW *) ,IF NOT ROOMONPAGE(PRINTSKIP, TESTLINES, ADDLINES, FALSE) THEN /IF ESCTYPED THEN 2EXIT(DISPRECS) /ELSE 2DISPHDR; )END; (* OF PAGEOVERFLOW *) & &BEGIN (* DISPRECS *) )INITREPORT(20, 20, FILENAME, SCREEN); )RECNUM:= 0; DO 5SCREENMSG(0, TMPINT, CLRLINE, NULLSTRG); 2GOTOXY(72, 2); 2WRITE('Page ', PAGENUMBER); 2LINESONPAGE:= LINESONPAGE+ 4; ) END; (* WITH *) )END; (* OF DISPHDR *) & &PROCEDURE PAGEOVERFLOW(PRINTSKIP: LINETYPE; ?TESTLINES, ADDLINES: INTEGER); ITH REPORTCTRL DO /BEGIN 2IF PAGENUMBER= 1 THEN 2 BEGIN 8SCREENMSG(0, 2, NULLCMD, 'Record Type Description'); 8JUSTIFY(NULLSTRG, TMPSTRG, LEFT, DASH, 80); 2 SCREENMSG(0, 3, NULLCMD, TMPSTRG); 5END; (* IF *) 2FOR TMPINT:= PHYSICAL DOWNTO 4 8TODAY:= RESPONSE; / END; (* IF *) /END; (* IF *) )UNTIL VALID; &END; (* OF CHGACTDATE *)  #PROCEDURE DISPRECS; &VAR )TMPBOOL +: BOOLEAN; & &PROCEDURE DISPHDR; )VAR ,TMPINT /: INTEGER; ,TMPSTRG .: STRING; )BEGIN (* DISPHDR *) ) WTHEN /RESPOND(ERROR, 'Not a valid date') ,ELSE /BEGIN 2VALID:= TRUE; 2IF TODAY<> RESPONSE THEN 2 BEGIN 8PINVGLOB.PGLOB^.TODAYINT:= TMPDATE; 8PINVPARS^.HDRPUT:= TRUE; 8PUTHDR(INVVAR, PINVPARS); / TESTFATAL(PUTHDRERR); INVVAR, PINVPARS, PINVGLOB.PBUF); )TESTFATAL(GETGLBERR); )REPEAT ,VALID:= FALSE; ,SCREENMSG(0, 3, NULLCMD, 'Activity Date? '); ,PROMPT(15, 3, 6, TODAY, RESPONSE, [STDDATE]); ,IF ESCTYPED THEN /EXIT(CHGACTDATE); ,IF NOT VALIDDATE(RESPONSE, TMPDATE) SG(0, 22, NULLCMD, 'Deletion cancelled'); )UNTIL FALSE; &END; (* OF DELRECS *)  #PROCEDURE CHGACTDATE; &VAR )VALID +: BOOLEAN; )TMPDATE +: DATEINT; )RESPONSE +: STRING; &BEGIN (* CHGACTDATE *) )STDSCREEN('Change Activity Date'); )GETGLOBALS(2SCREENMSG(0, 22, NULLCMD, 'Record deleted'); / IF PINVPARS^.NUMINFILE= 0 THEN 5BEGIN 8RESPOND(WARNING, CONCAT(FILENAME, ' is now empty')); 8FORCEWRITE(INVVAR, PINVPARS); 8TESTFATAL(FORCEERR); 8EXIT(DELRECS); 5END; (* IF *) /END ,ELSE /SCREENMcord? '); ,ALTCHR:= NULLSET; ,IF RSPCHR IN ['Y', 'y'] THEN /BEGIN 2PUTREC(INVVAR, PINVPARS, FALSE); 2TESTFATAL(PUTRECERR); 2CHANGEHDR(INVVAR, PINVPARS, RECNUM, INACTIVE, FALSE); / TESTFATAL(CHGHDRERR); 2BUILDKEY; 2DELETEKEY(INVTREE, INVKEY); INVENTORY FILE BASED ON USER INTERACTION '* '*) &BEGIN (* DELRECS *) )STDSCREEN('Delete Records'); )REPEAT ,GETRECNUM; ,IF RECNUM= 0 THEN /EXIT(DELRECS); ,(* CONFIRM THE DELETION *) ,ALTCHR:= ['Y', 'y', 'N', 'n']; ,RESPOND(QUIET, 'Delete this reect Records'); )REPEAT ,GETRECNUM; ,IF RECNUM= 0 THEN /EXIT(INSPECT); ,(* WAIT FOR USER TO READ THE SCREEN AND RESPOND *) ,RESPOND(QUIET, 'Type [RETURN] ') )UNTIL FALSE; &END; (* INSPECT *)  #PROCEDURE DELRECS; &(* '* DELETES RECORDS FROM THE INTEGER; ,TMPSTRG .: STRING; )BEGIN (* PRINTHDR *) ,JUSTIFY(CONCAT(FILENAME, ' Inventory'), TMPSTRG, LEFT, SPACE, 50); ,WRITELN(OUTTEXT, TMPSTRG, ' Page ', 6REPORTCTRL.PAGENUMBER); ,DATEDELIM:= SPACE; ,FMTDATE(TODAY, TMPSTRG, [FULLMON, FULLYEAR]); ,DATEDELIM:= DASH; ,WRITELN(OUTTEXT, 'Reflects all activity as of ', TMPSTRG); ,WRITELN(OUTTEXT); ,WRITELN(OUTTEXT, 'Record Type Description'); ,JUSTIFY(NULLSTRG, TMPSTRG, LEFT, DASH, 80); ,WRITELN(OUbbbbbbbbbbbbbbbbz@,88ndHINVENTOR ;'3': DELRECS; ;'4': INSPECT; ;'5': DISPRECS; ;'6': PRINTRECS; ;'7': CHGACTDATE; ;END; (* CASE *) 8STDSCREEN(BANNER); 8DISPMENU; , END; (* IF *) ,END; (* WITH *) &UNTIL FALSE; #END. (* OF INVENTORY *)  2RESPOND(ERROR, CONCAT('No records in ', FILENAME)) /ELSE 2IF (RSPCHR= '1') 8AND (NUMINFILE>= MAXALLOWED) THEN 5RESPOND(ERROR, CONCAT(FILENAME, ' is full')) 2ELSE 5BEGIN 8ADDING:= (RSPCHR= '1'); 8CASE RSPCHR OF ;'1': ADDRECS; ;'2': CHANGERECS; &DISPMENU; &REPEAT )SCREENMSG(0, 23, CLRLINE, 'Your Choice? '); )GETCHR(0, FALSE, MENUSET); )IF ESCTYPED THEN ,TERMINATE; )WITH PINVPARS^, FHDR.PARS^ DO ,BEGIN /IF (RSPCHR IN ['2'..'6']) 5AND (NUMINFILE< 1) THEN ); # SCREENMSG(0, 8, NULLCMD, '5. Display Records'); )SCREENMSG(0, 9, NULLCMD, '6. Print Records'); )SCREENMSG(0, 11, NULLCMD, '7. Change Activity Date'); &END; (* OF DISPMENU *) # #BEGIN (* INVENTORY *)  INITIALIZE; &STDSCREEN(BANNER); RUE); &END; (* OF PRINTRECS *) # #PROCEDURE DISPMENU; &BEGIN )SCREENMSG(0, 3, NULLCMD, '1. Add Records'); )SCREENMSG(0, 4, NULLCMD, '2. Change Records'); )SCREENMSG(0, 5, NULLCMD, '3. Delete Records'); )SCREENMSG(0, 6, NULLCMD, '4. Inspect Records'5JUSTIFY(ITEMTYPE, TMPSTRG, LEFT, SPACE, 6); 5WRITELN(OUTTEXT, RECNUM: 6, ' ', TMPSTRG, =ITEMDESC); , END; (* IF *) /FOUND:= FINDKEY(INVTREE, NULLSTRG, NEXTGE, INVKEY); ,END; (* WHILE *) & TMPBOOL:= ROOMONPAGE(SKIP, REPORTCTRL.PHYSICAL, 0, TINVKEY); )WHILE FOUND DO ,BEGIN , RECNUM:= ORD(INVKEY[10])* 256+ ORD(INVKEY[11]); /GETREC(INVVAR, PINVPARS, RECNUM, PINVREC.PBUF); /TESTFATAL(GETRECERR); /PAGEOVERFLOW(PRINT, 1, 1); /WITH PINVREC.PREC^ DO / BEGIN FALSE) THEN /IF ESCTYPED THEN 2EXIT(PRINTRECS) /ELSE 2PRINTHDR; )END; (* OF PAGEOVERFLOW *) & &BEGIN (* PRINTRECS *) )INITREPORT(60, 66, 'Print Records', PRINTER); )IF ESCTYPED THEN ,EXIT(PRINTRECS); )FOUND:= FINDKEY(INVTREE, NULLSTRG, FIRSTGE, TTEXT, TMPSTRG); ,WITH REPORTCTRL DO /LINESONPAGE:= LINESONPAGE+ 5; )END; (* OF PRINTHDR *) & &PROCEDURE PAGEOVERFLOW(PRINTSKIP: LINETYPE; ?TESTLINES, ADDLINES: INTEGER); )BEGIN (* PAGEOVERFLOW *) ,IF NOT ROOMONPAGE(PRINTSKIP, TESTLINES, ADDLINES,  šعצCAN'T PROCESS BLOCKPצCAN'T UPDATE HEADERPצCAN'T CLOSE FILEPCAN'T SCAN HEADERתPCAN'T UPDATE FILEתPCAN'T GET ACTIVITY DATEתPCAN'T READ RECORDתPCAN'T OPEN FILEתPsCAN'T WRITE HEADERתPXצ |Ʉ.No records in 6~1éĄ(( is full0E1ë . *&"17$" 3|ange Recordsצ3. Delete Recordsצ4. Inspect Records5. Display Records צ6. Print Records 7. Change Activity Date|Χ3 Your Choice? Aꫂ"`  |  š#|` |  *H3b6zBpv0B"dz J r $ @ J .5. Display Records צ6. Print Records 7. Change Activity Date|Χ3 Your Choice? AꫂN^Sƣ)GETSRCHVAL(WHAT2DELETE); )WHILE SRCHVAL<> NULLSTRG DO ,BEGIN /JUSTIFY(SRCHVAL, SRCHVAL, LEFT, SPACE, KEYLENGTH); /IF FINDKEY(TESTTREE, SRCHVAL, FIRSTEQ, TMPKEY) THEN 2BEGIN 5DELETEKEY(TESTTREE, SRCHVAL); 5INORDER(TESTTREE, NULLSTRG); / END /ELIRSTEQ, TMPKEY) THEN 2BEGIN 5INSERTKEY(TESTTREE, SRCHVAL); 5INORDER(TESTTREE, NULLSTRG); / END /ELSE 2RESPOND(ERROR, CONCAT(SRCHVAL, ' is already in the Tree.')); /GETSRCHVAL(WHAT2INSERT); ,END; (* WHILE *) ) )MATCH; ) (* TESTBTREE *) &WRITELN; &WRITELN('Testing BTREE'); &OPENTREE(TESTTREE, KEYLENGTH, 2); &REPEAT )GETSRCHVAL(WHAT2INSERT); )WHILE SRCHVAL<> NULLSTRG DO ,BEGIN /JUSTIFY(SRCHVAL, SRCHVAL, LEFT, SPACE, KEYLENGTH); /IF NOT FINDKEY(TESTTREE, SRCHVAL, FREE, SRCHVAL, NEXTEQ, FOUNDKEY); ,END; (* WHILE *) & WRITELN; &END; (* OF INORDER *) # #PROCEDURE MATCH; &BEGIN (* MATCH *) )REPEAT ,GETSRCHVAL(WHAT2MATCH); ,INORDER(TESTTREE, SRCHVAL); )UNTIL SRCHVAL= NULLSTRG; &END; (* OF MATCH *) & #BEGIN&BEGIN (* INORDER *) )SCREENMSG(0, 0, CLRSCREEN, NULLSTRG); )SCREENMSG(0, 2, NULLCMD, 'Testing BTREE'); )GOTOXY(0, 4); )FOUND:= FINDKEY(TREE, SRCHVAL, FIRSTEQ, FOUNDKEY); )WHILE FOUND DO ,BEGIN /WITH TREE DO 2WRITELN(FOUNDKEY); /FOUND:= FINDKEY(TMPTSTRG); )PROMPT(LENGTH(PROMPTSTRG), 23, KEYLENGTH, NULLSTRG, SRCHVAL, []); & IF ESCTYPED THEN ,EXIT(PROGRAM); &END; (* OF GETSRCHVAL *) # #PROCEDURE INORDER(TREE: TREEPARS; SRCHVAL: STRING); &VAR )FOUND +: BOOLEAN; )FOUNDKEY +: STRING; 'What is the key you wish to delete? '; &WHAT2MATCH= ('What is the match key? '; #VAR &SRCHVAL, &TMPKEY (: STRING[16]; # TESTTREE (: TREEPARS; # #PROCEDURE GETSRCHVAL(PROMPTSTRG: STRING); &BEGIN (* GETSRCHVAL *) )SCREENMSG(0, 23, CLRLINE, PRO EACH STEP PROCEEDS TO THE NEXT STEP IF '' IS INPUT, $* AND TERMINATES THE PROGRAM IF ESC IS INPUT. $*) #USES &APPLESTUFF, &GENUTIL, &BTREE; # #CONST &KEYLENGTH= 5; &WHAT2INSERT= ('What is the key you wish to insert? '; &WHAT2DELETE= (  (*$S++*)  (*$V-*)  PROGRAM TESTBTREE; #(* $* B-TREE SEARCH, INSERTION AND DELETION $* $* FLOW: $* $* REPEAT $* ADD KEYS $* SEARCH FOR MATCHES $* DELETE KEYS $* SEARCH FOR MATCHES $* UNTIL FALSE; $* $* SE 2RESPOND(ERROR, CONCAT(SRCHVAL, ' is not in the Tree.')); /GETSRCHVAL(WHAT2DELETE); ,END; (* WHILE *) & )MATCH; # &UNTIL FALSE; #END. (* OF TESTBTREE *)  SFe Star WarsAsciifile/DataSFe2001 A Space Odyssey/DataSFeEmpire Strikes Back, TheaMYSMurder by Decreeack, TheaSFSClose Encountersack, TheaMYSBig Sleep, Thersack, TheaSFSForbidden Planetack, Thea . Testing BTREEצ$What is the key you wish to insert?  ׷    צ211 1 is already in the Tree.(1$What is the key you wish to insert? צ$What is the key you wish to delete?  ׷    .11 1צ is not in the Tree.$1צ$What is the key you wish to delete? 7>> Testing BTREEצ$What is the key you wish to insert?  ׷    צ211 1 is already in the Tree.(1$What is the key you wish to insert? צ$What is the key yتPץ  R0,٨تPצ Testing BTREE,IHH#I,IH2 vצWhat is the match key?   צ. 6Χbbbbbbbbbbbbbbbbr@88ndTESTBTRE /// /// /// /// /// /// /// /// /// /// /// /// /// /// /// /// SIG, Washington Apple Pi 12022 Parklawn Drive Rockville, MD. 20852 (301)-984-030REE.CODE; VIDEOTAPE.INV On Side Two (Putlib): GENUTIL.TEXT; GENUTIL2.TEXT; GENUTIL3.TEXT; FILEACCESS.TEXT; BTREE.TEXT; BTREE2.TEXT; SYSTEM.LIBRARY; LIBRARY.CODE opying. Contact Dave Ottalini for details at 301-681-6136. On Side One (Putdemo): TESTUNIT.TEXT; TESTUNIT2.TEXT; TESTUNIT.CODE; CREATEFILE.TEXT; CREATEFILE.CODE; LISTSTATUS.TEXT; LISTSTATUS.CODE; INVENTORY.TEXT; INVENTORY.CODE; TESTBTREE.TEXT; TESTBTned in the documentation. This will encourage well-organized, readable code. Requires knowledge of Pascal to use. The WAP /// SIG has many copies of the Pascal manuals. Call the office for details. The manual for this disk is available for the cost of ctes. The TESTUNIT program provided with this package will permit you to observe the effect of calling the modules with specific parameter values. In an application program, it remains the programmer's responsibility to call the modules properly as defig of data files. - The B-tree modules combine features of sequential and binary tree access to provide a means of sorting and searching through data in memory. The underlying data structure is flexible enough to accomodate any key length from 1 to 16 byn groups of modules: - The General Utility modules relieve the burden of writing the general-purpose routines needed for user-program interaction, error-checking, and data conversion. - The file Access modules are a powerful tool for consistent handlin with the tools needed to write sophisticated programs for any application. The aim is to free the programmer from tedious coding of details so that he can concentrate on program function. To this end, the Pascal Utility Library id divided into three mai0 WAP /// SIG PUBLIC DOMAIN LIBRARY PDS NAME: Pascal Utilities: Putdemo & Putlib Demos DISK ID#: 3PCL-07 BOOTABLE?: Nonbootable DESCRIPTION: The Apple /// Pascal Utility Library is meant to provide the knowledgeable A3 Pascal programmer