IMD 1.17: 24/11/2010 19:43:53 15 backup1  @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ TEXTi*D COM.INIT.TEXTiDT MOUSE.TEXT:lmT|COM.TEXTk| SPRUCE.B.TEXTk SPRUCE.A.TEXTk SPRUCE.TEXTk PMD.DOC.TEXTkBBACKUP1~%Z STR.TEXT"  RANIO.TEXT" DISPLAY.TEXT"R VALDEC.TEXT"CHCHARSET.TEXT%( MAKED.TEXT"(: CALLS.TEXT"b6:B QSORT.TEXT"ŜBZ DECLIST.TEXTHh4Zt CALC.TEXT"jft CALLS2.TEXT"6 PLOTTER.TEXT"CAT.TEXTTj| PLOT.TEXT"ŝRAN.TEXTj蝴HDO.TEXTmX BOOT.TEXTj|( COMPARS.TEXTj|SNOWFLAKE.TEXTh LOWER.TEXTh UPLOW.TEXTh DIGITS.TEXThODT.TEXTm* COM.UTIL. ]) ;  END ; (* WRITESTR *)   PROCEDURE WRITELNSTR(VAR FL : TEXT ; VAR S : STR) ;  VAR I : INTEGER ;  BEGIN (* WRITELNSTR **$IUTIL.TEXT*)  BEGIN  RANOPEN('DATA.TEXT') ; (WHILE NOT RANEOF DO (BEGIN (* CL *) 0GETRANLINE(L) ; 0WITH L DO FO)  WITH S DO (FOR I := 1 TO LEN DO WRITE(FL, IMAGE[I]) ; (WRITELN(FL) ;  END ; (* WRITELNSTR *)  R I := 1 TO LEN DO WRITEOCT(ORD(IMAGE[I]), 4) ; 0WRITELN ; 0WITH L DO FOR I := 1 TO LEN DO WRITE(IMAGE[I] : 4) ; 0WRITELN ; (END ; (* CL *) END. PROCEDURE READSTR(VAR FL : TEXT ; VAR S : STR) ;  BEGIN (* READSTR *)  WITH S DO  BEGIN (* RS *) (GET(FL) ; LEN := 0 ;  WHILE (NOT EOLN(FL)) AND (NOT EOF(FL) AND (LEN < STRLEN)) DO (BEGIN (* RG *) (LEN := LEN + 1 ; (IMAGE[LEN] := FL^ ; (GET(FL) ; END ; (* RG *)  END ; (* RS *)  WHILE NOT EOLN(FL) DO GET(FL) ; END ; (* READSTR *)  PROCEDURE WRITESTR(VAR FL : TEXT ; VAR S : STR) ;  VAR I : INTEGER ;  BEGIN (* WRITESTR *)  WITH S DO (FOR I:= 1 TO LEN DO WRITE(FL, IMAGE[IPROGRAM RANIO ;  (*$ISTRDEC*)  (*$IRANDEC*)  L : STR ;  I, J : INTEGER ; (*$IRAN.TEXT*)  (*$ISTR.TEXT*)  ( (* DISPLAY : Print resident character set  (George Gonzalez 013-FEB-78  *)   PROGRAM DISPLAY ;  VAR (I, C, J : INTEGER ;  (*$IUTIL.TEXT*) BEGIN (PAGE(OUTPUT) ; WRITELN ; WRITELN ; (WRITELN(' Current resident character set') ; WRITELN ; WRITE(' ') ; FOR I := 0 TO 15 DO WRITEOCT(I , 3) ; (WRITELN ; WRITELN ; (FOR J := 0 TO 15 DO (BEGIN (* ROW *) 0IF J = 8 THEN WRITELN ; WRITEOCT( J+J, 3 ) ; WRITE(' ') ; 0FOR I := 0 TO 15 DO 0BEGIN (* COL *) 4C  := J * 16 + I ; 4IF C MOD 128 < 32 THEN WRITE('~') 4ELSE WRITE(CHR(C)) ; 4WRITE(' ') ; 0END ; (* COL *) 0WRITELN ; (END ; (* ROW *)  END.  EGER ; (PERFMODE : BOOLEAN ; (SKIPMODE : BOOLEAN ; (GOTOMODE : BOOLEAN ; (CURCHAPTER : INTEGER ; (CURDRILL : INTEGER ; (CURFRAME : INTEGER ; (TIMESQUEST : INTEGER ; (HOURSON : REAL ; (PASSWORD : INTEGER (END ; (* VALREC *)  (*  Program Chchset : change resident character set  *)  PROGRAM CHCHSET;  VAR #FNAME1 : STRING; #FOUND : VAR (VAL : FILE OF VALREC ; BOOLEAN;  PROCEDURE CHCHARSETP(FNAME1:STRING;VAR FOUND:BOOLEAN); TYPE #CHARSET = ARRAY [32..127] OF PACKED ARRAY [0..9] OF CHAR; #BITWORD = PACKED ARRAY [0..15] OF BOOLEAN; #BUFGENT = RECORD 2CASE INTEGER OF 51:(A: BITWORD); 52:(I: INTEGER); 53:(P: ^CHAR) 2END; #CHARBT = RECORD 2SET1 : CHARSET; 2FILLER1 : PACKED ARRAY [0..63] OF CHAR; 2SET2 : CHARSET; 2FILLER2 : PACKED ARRAY [0..63] OF CHAR /END; #VCRP = RECORD 2CASE INTEGER OF 51:(I:INTEGER); 52:(P:^BITWORD) 2END; O^  VAR #I : INTEGER; #F : FILE OF CHARBT; #FNAME : STRING; #BUFGEN : BUFGENT; VCR : VCRP;  BEGIN #FNAME:=CONCAT(FNAME1,'.CHARSET'); #(*$I-*) #OPENOLD(F,FNAME); #(*$I+*) #FOUND:=IORESULT=0; #IF FOUND & THEN BEGIN .GET(F); .VCR.I:= -28 ; (* VCR ADDRESS: -28 *) .VCR.P^[7]:= TRUE ; (* GENBUF IS TO BE ACCESSED. *)   (* Validation record *)   CONST PW = 1009 ; (* MIX *)  TYPE VALREC = RECORD (STUDENTNAME : STRING ; (AUTHORMODE : BOOLEAN ; (COURSE : STRING ; (FURCHAPTER : INTEGER ; (FURDRILL : INTEGER ; (FURFRAME : INT N.I:=512-6144; .FOR I:= 32 TO 127 DO 1BEGIN 4MOVELEFT(F^.SET2[I],BUFGEN.P^,10); 4BUFGEN.I:= BUFGEN.I+16 1END; .CLOSE(F); .VCR.P^[7]:= FALSE; (* PAGEBUF CAN BE ACCESSED AGAIN. *) .WRITELN('New charset is:',FNAME1) +END  END;    BEGIN #WRITE('What''s the new charset?'); #READLN(FNAME1); #CHCHARSETP(FNAME1,FOUND); #IF NOT FOUND THEN WRITELN(FNAME1,' not found!')  E  (* MAKEDIRECTORY : Create directory for a CALLS file  (George Gonzalez (16-APR-78 ( ('Makedirectory' reads a CALND. LS text file and generates (a directory file (name.DIR). The directory contains a (pointer to every drill found in the text file. The (directory entries are sorted by drill (numbers. (  *)  PROGRAM MAKEDIRECTORY ;   (*$IDIRDEC.TEXT*) (*$ISTRDEC.TEXT*)  VAR (NAME, NAMETXT : STRING ;  LINE : STR ;  DRILLN : INTEGER ; (* CURRENT DRILL # *) DIRINDEX : INTEGER ; (* LATEST DIRECTORY ENTRY *) BOLBLK, BOLPTR : INTEGER ; (* START OF CURRENT LINE *) (*$IRANDEC.TEXT*) (O^*$IRAN.TEXT*)  (*$ISTR.TEXT*) (*$R+*)  PROCEDURE DOIT ; FORWARD ; (* EXITED FROM ASKABORT *) PROCEDURE ASKABORT ; (* ABORT OR CONTINUE *)  VAR C : CHAR ;  BEGIN (WRITE('Hit to continue, to abort') ; (READ(KEYBOARD, C) ; (IF C = CHR(27) THEN EXIT(DOIT) ;  END ; (* ASKABORT *)   PROCEDURE ERROR( S : STRING) ; (* PRINT ERROR MESSAGE *)  BEGIN (WRITELN ; WRITELN('** ERROR ** ?', S, '? at line:') ; (WRITELNSTR(OUTPUT, LINE) ; (ASKABORT ;  END ; (****** PRTDIR is not active   PROCEDURE PRTDIR ;  VAR I : INTEGER ;  BEGIN WRITELN ; WRITELN(' Directory') ; WRITELN(' Drill Block Byte') ;.BUFGEN.I:=512-8192; .FOR I:= 32 TO 127 DO 1BEGIN 4MOVELEFT(F^.SET1[I],BUFGEN.P^,10); 4BUFGEN.I:=BUFGEN.I+16 1END; .BUFGE  - 1 0END (* SWAP *) (UNTIL I > J ; (IF L < J THEN QSORT(L, J) ; (IF I < R THEN QSORT(I, R)  END (* Q *) END ; (* QSORT *) K) ;  WRITELN('File ', NAME, '.DIR created.') ; GET(INPUT) ; END ; (* DOIT *)   BEGIN (* MAIN *) INT  PROCEDURE DRILLHEADER ; (* EVAL A DRILL HEADER *)  VAR I : INTEGER ;  BEGIN (* DRILLHEADER *) (I := 3 ; DRILLN := 0 ; (RO ; (DOIT ;  END.   FOR I := 1 TO DIRECTORY^.DIRSIZE DO (WITH DIRECTORY^.DIRDATA[I] DO (WRITELN(FDRILL : 6, FBLOCK : 6, FBYTE : 6) ;  WRITELN WITH LINE DO WHILE (IMAGE[I] IN ['0'..'9']) AND ( I < 6 ) DO (BEGIN (* TOT *) ; READLN  END ; "***) "  PROCEDURE INTRO ; (* SETUP INITIAL CONDITIONS *)  VAR ERR : BOOLEAN ; DOT : INTEGER ;  (*$I-*)+DRILLN := DRILLN * 10 + ORD(IMAGE[I]) - ORD('0') ; +I := I + 1 (END ; (* TOT *) (IF ( I = 3 ) OR ( DRILLN > DRILLH BEGIN (* INTRO *) (PAGE(OUTPUT) ; (WRITELN ; WRITELN(' ':20, 'MAKEDIR - Create CALLS Directory') ; #REPEAT WRITELN ;I ) THEN -ERROR('Invalid drill number') ;  END ; (* DRILLHEADER *)   PROCEDURE GETHEADER ; (* SKIP TIL A HEADER OR EOF *)  (WRITE('File name? ') ; (READLN( NAME ) ; (DOT := POS( '.', NAME) ; (IF DOT > 0 THEN NAME := COPY( NAME, 1, DOT-1 ) ;  BEGIN (* GETHEADER *)  WITH LINE DO BEGIN (* WL *) REPEAT (BOLPTR := BUFPTR ; BOLBLK := RESBLK ; GETRANLINE(LINE) ; U NAMETXT := CONCAT( NAME, '.TEXT' ) ; (ERR := NOT RANOPEN(NAMETXT) ; (IF ERR THEN WRITELN('? ', NAMETXT, ' Not found?') ; #NTIL RANEOF OR  ((IMAGE[1] IN ['0'..'4']) AND ! (IMAGE[2] IN ['D', 'd']) AND (LEN >= 2)) ; IF NOT RANEOF THEN DRILLHEADER ; UNTIL NOT ERR ; #OPENNEW(DIRECTORY, CONCAT(NAME, '.DIR') ) ; #IF IORESULT <> 0 THEN #WRITELN('?Can''t open output file?') ;  END ; (* WL *) END ; (* GETHEADER *)  PROCEDURE MARKHEADER ; (* PLACE FRAME INFO INTO DIRECTORY *)  BEGIN (* MARKHEADER *) (DIRINDEX := 0 ; DRILLN := -1 ; (WITH DIRECTORY^.DIRDATA[0] DO (BEGIN (* CLR *) (FDRILL := -1 ; (END (* CLR *) END (IF DIRINDEX >= MAXDRILLS THEN ERROR('Directory overflow') ; (DIRINDEX := DIRINDEX + 1 ; (WITH DIRECTORY^.DIRDATA[DIRINDEX] DO; (* INTRO *)  (*$I+*)  PROCEDURE QSORT( L, R : INTEGER ) ; (* SORT DIRECTORY ENTRIES *)  VAR (I, J, X : INTEGER ; (W : DR (BEGIN (* SETD *) 0FDRILL := DRILLN ; 0FBLOCK := BOLBLK ; 0FBYTE := BOLPTR ; (END ; (* SETD *)  DIRECTORY^.DIRSIZILLINFO ;  BEGIN WITH DIRECTORY^ DO  BEGIN (* Q *) (I := L ; J := R ; (X := DIRDATA[(I+J) DIV 2].FDRILL ;  (REPEAT E := DIRINDEX ; END ; (* MARKHEADER *)   PROCEDURE DOIT ; (* MAIN PROCESSOR *)  BEGIN (* DOIT *) (SEEK(0, 1) ; (REPEAT  WHILE DIRDATA[I].FDRILL < X DO I := I + 1 ; WHILE X < DIRDATA[J].FDRILL DO J := J - 1 ; 0GETHEADER ; 0IF NOT RANEOF THEN MARKHEADER ; ( WRITELN('Processing drill ', DRILLN) ; (UNTIL RANEOF ; (WRITELN(DIRE IF I <= J THEN 0BEGIN (* SWAP *) 8W := DIRDATA[I] ; 8DIRDATA[I] := DIRDATA[J] ; 8DIRDATA[J] := W ; 8I := I + 1 ; J := JCTORY^.DIRSIZE, ' Frames processed.') ; QSORT( 1, DIRECTORY^.DIRSIZE ) ; PUT(DIRECTORY) ; (CLOSE(DIRECTORY, LOC ) (*$IKBD.TEXT*) (*$ICALLS2.TEXT*) PROCEDURE NEXTFRAME ; BEGIN #RELFRAME := RELFRAME + 1 ; #IF (LINE.IMAGE[2] IN ['D', 'd']) AND (LINE.LEN >= 2) OR RANEOF &THEN )BEGIN (* FRESHDRILL *) ,IF WRONG > MAXRPT /THEN 2BEGIN (* REDO *) 5AT(20, 10) ; 5P(RETURNSTR) ; 5WAITCR ; 5SEEKDRILL(DRILLINDEX) ; 2END (* REDO *) /ELSE 2BEGIN (* NEXT *) 5IF DRILLINDEX >= DIRECTORY^.DIRSIZE 8THEN ;BEGIN (* NEW CHAPTER *) >FETCH(RESCHAPTER+1) ; >SEEKDRILL(1) ; ;END (* NEW CHAPTER *) 8ELSE ;SEEKDRILL(DRILLIND(* Program CALLS : Computer Aided Language Learning System *George Gonzalez *CGID *11-MAY-78 *CALLS is a generalizeEX+1) ; 2END ; (* FRESHDRILL*) ,WITH VAL^ DO /BEGIN (* V *) 2CURDRILL := DIRECTORY^.DIRDATA[DRILLINDEX].FDRILL ; 2CURCHAPTEd tool for presenting language *drills and testing. This program, the CALLS processor, *interprets the directives found in a CALLS text file *and presents the desired drills and tests. *) PROGRAM CALLS ; CONST STARS = '***' ; &DELAY = 3000 ; &BS = 8 ; TYPE SETC = SET OF CHAR ; (* Included declarations *) (*$IVALDEC.TEXT*) (*$IDIRDEC.TEXT*) (*$ISTRDEC.TEXT*) (*$IRANDEC.TEXT*) %STUNAME, LINE, KW, OKSTR, NOSTR, GIVEUPSTR, %HINTSTR, IMB, KMB, DMB, RETURNSTR, BYESTR, NEXT : STR ; %FIRSTNAME, VNAME, KEYWORD : STRING ; %COL1 : CHAR ; %NULLFRAME, TESTMODE, EMPTY, QUIT : BOOLEAN ; %I, J, NEWDRILL, NEWFRAME, RESCHAPTER, %TRIES, MAXTRIES, SAVEBLOCK, SAVEBYTE, %MAXRPT, MAXSKIP, GOTOCH, GOTODRILL, GOTOFRAME, %WRONG, LINEBLOCK, LINEBYTE, NLBLOCK, NLBYTE, %RELFRAME, PROBE, DRILLINDEX : INTEGER ; (* Included subprograms *) (*$IRAN.TEXT*) (*$ISTR.TEXT*) (*$IUTIL.TEXT* CR ; END ; (* TYPE1FRAME *) PROCEDURE TYPE2FRAME ; (* PRESENT TEXT AND MATCH ANSWER *) VAR WORDS, WORDPTR, I : INTEGER ; ,THEN /BEGIN (* PROCESS LAST CHARACTER A '.' *) 2DMB.IMAGE[DMB.LEN] := '.'; /END (* PROCESS LAST CHARACTER A '.' *) ,E$MATCH, ERR : BOOLEAN ; PROCEDURE BLANK (VAR BUF: STR) ; BEGIN #WITH BUF DO &BEGIN (* WITH *) )WHILE (( IMAGE[ PTR] <> ' ' LSE /BEGIN (* PROCESS LAST CHARACTER NOT A '.' *) 2DMB.IMAGE[DMB.LEN] := '-'; /END ; (* PROCESS LAST CHARACTER NOT A '.' *)) /AND (PTR < LEN)) DO ,BEGIN /PTR := PTR + 1; ,END ; )ERR := ERR OR (LEN < PTR) OR (IMAGE[PTR] <> ' ') ; &END ; (* WITH #TRIES := 0; #REPEAT &KBDIN ; &ADDSPACE(IMB) ; &IMB.PTR := 1; &KMB.PTR := 2; &ERR := FALSE ; &NONBLANK(IMB) ; &NONBLA *) END ; (* SKIP TO NEXT NONBLANK *) PROCEDURE NONBLANK( VAR BUF : STR) ; BEGIN #WITH BUF DO &BEGIN (* WITH *) )WHILE (( INK(KMB) ; &WHILE NOT ERR DO )BEGIN (* NOT EOL KMB OR IMB *) ,WORDPTR := KMB.PTR; ,MATCH := TRUE ; ,IMB.PTR := IMB.PTR - 1 MAGE[PTR] = ' ' ) ; ,KMB.PTR := KMB.PTR - 1 ; ,REPEAT /IMB.PTR := IMB.PTR + 1; /KMB.PTR := KMB.PTR + 1; /MATCH := MATCH AND 8(KMB.IMAGE[KMB/AND (PTR < LEN)) DO ,BEGIN /PTR := PTR + 1; ,END ; )ERR := ERR OR (LEN < PTR) OR ( IMAGE[PTR] = ' ') ; &END ; (* WITH *.PTR] = IMB.IMAGE[IMB.PTR]) ; ,UNTIL (IMB.IMAGE[IMB.PTR] = ' ') 2OR (NOT MATCH) OR ( KMB.PTR >= KMB.LEN) ; ,IF MATCH /THEN ) END ; PROCEDURE ADDSPACE( VAR S : STR ) ; (* ADD A TRAILING SPACE *) BEGIN #WITH S DO &BEGIN (* S *) )LEN := LEN + 1 ; )I2BEGIN (* A COMPLETE WORD MATCH *) 5WORDS := WORDS - 1; 5IF ( WORDS > 0 ) 8THEN ;BEGIN (* WORDS REMAINING *) >FOR I := WMAGE[LEN] := ' ' ; &END ; (* S *) END ; (* ADDSP *) BEGIN (* TYPE2 *) #HEADERTEXT ; #WORDS := 0; #KMB := LINE; #DMB.LEN :=ORDPTR TO KMB.PTR DO R := RESCHAPTER ; 2FURDRILL := MAX(FURDRILL, CURDRILL) ; 2FURCHAPTER := MAX(FURCHAPTER, RESCHAPTER) ; /END ; (* V *) )END ;  1; #DMB.IMAGE[1] := ' '; #REPEAT &DMB.LEN := DMB.LEN+1; &IF (LINE.IMAGE[DMB.LEN] = ' ') )OR (DMB.LEN = LINE.LEN) )THEN (* NEXT *) ,BEGIN (* PROCESS A BLANK *) /DMB.IMAGE[DMB.LEN] := ' '; /IF ( DMB.IMAGE[DMB.LEN-1] <> ' ') 2THEN 5BEGIN (* COUNT A NEW WOEND ; (* NEXTFRAME *) PROCEDURE FINDFILE ; (* POSITION US AT FIRST PLACE IN CHAPTER *) BEGIN #RESCHAPTER := -1 ; (* NO CHAPTERRD *) 8WORDS := WORDS + 1; 5END ; (* COUNT A NEW WORD *) ,END (* PROCESS A BLANK *) )ELSE ,BEGIN (* PROCESS A NONBLANK, INITIALLY *) #FETCH(0) ; #SEEKDRILL(1) ; END ; (* FINDPLACE *) PROCEDURE BADANSW ; (* TALLY BAD ANSWER *) BEGIN #WRONG :=  *) /DMB.IMAGE[DMB.LEN] := '-'; ,END ; (*PROCESS A NONBLANK *) #UNTIL ( DMB.LEN >= LINE.LEN ) ; #IF LINE.LEN > 0 &THEN WRONG + 1 ; END ; (* BADANSW *) PROCEDURE TYPE1FRAME ; (* PRESENT TEXT *) BEGIN #HEADERTEXT ; #IF NOT NULLFRAME &THEN )WAIT)IF ( LINE.IMAGE[LINE.LEN] = '.' )  MB); 2END ; (* NOT A WORD MATCH *) ,IMB.PTR := IMB.PTR + 1 ; ,KMB.PTR := KMB.PTR + 1 ; ,NONBLANK(IMB) ; ,NONBLANK(KMB) ; S < MAXTRIES) )END ; (* NOT EOL KMB OR IMB *) &IF ( WORDS > 0 ) )THEN ,BEGIN /TRIES := TRIES + 1; /IF ( TRIES < MAXTRIES ) 2THEN 5BEGI)THEN ,P(NOSTR) ; #UNTIL MATCHED OR (TRIES >= MAXTRIES) ; #IF MATCHED &THEN )POSITION(GOTOCH, GOTODRILL) &ELSE )BEGIN (N (* NOT LAST TRY *) 8P(NOSTR) ; 8WRITE(OUTPUT, ' ') ; 8P(DMB) ; 5END ; (* NOT LAST TRY *) ,END ; #UNTIL ((WORDS = 0) OR* NEXT ANSWER *) ,P(GIVEUPSTR) ; ,REPOSITION ; ,MATCH ; ,P(LINE) ; ,BADANSW ; ,SKIPTO(['1'..'4']) ; )END ; (* NEXT ANSWER (TRIES>=MAXTRIES)) ; #IF ( WORDS = 0 ) &THEN )BEGIN ,P(OKSTR); )END &ELSE )BEGIN ,P(GIVEUPSTR); ,WRITE(OUTPUT, ' ')  *) END ; (* TYPE4FRAME *) PROCEDURE DOFRAME ; BEGIN #CASE COL1 OF &'1' : TYPE1FRAME ; &'2' : TYPE2FRAME ; &'3' : TYPE3FRA; ,P(LINE) ; ,BADANSW ; )END ; #WAITCR; #GETLN ; END ; (* TYPE2FRAME *) PROCEDURE TYPE3FRAME ; (* PRESENT TEXT AND FLIP PAME ; &'4' : TYPE4FRAME #END ; #IF (NOT RANEOF) AND (NOT (COL1 IN ['1'..'4'])) &THEN )BEGIN ,ERROR('Invalid frame type:', FGE *) ALSE) ; ,P(LINE) ; ,GETLN ; )END ; #NEXTFRAME ; END ; (* DOFRAME *) PROCEDURE DODRILLS ; (* PRESENT DRILLS *) BEGIN #REPEABEGIN #TYPE1FRAME ; END ; (* TYPE3FRAME *) PROCEDURE TYPE4FRAME ; (* PRESENT TEXT AND MATCH MULTIPLE *) VAR MATCHED : BOOT &DOFRAME ; #UNTIL QUIT AND (NOT QUIT) ; END ; (* DODRILLS *) BEGIN #LOGIN ; #IF TRIES < 3 &THEN )BEGIN ,VALIDATE ; ,FLEAN ; PROCEDURE REPOSITION ; BEGIN #SEEK(SAVEBLOCK, SAVEBYTE) ; #EMPTY := TRUE ; #GETLN ; END ; (* REPOSITION *) PROCEDUREINDFILE ; ,DODRILLS ; ,WINDUP ; )END &ELSE )WRITELN('Please get someone to help you') ; END.  SKIPTO( TARGET : SETC) ; (* SKIP TIL TARGET *) BEGIN #REPEAT &GETLN ; #UNTIL RANEOF OR ( COL1 IN TARGET ) ; END ; (* SKIPTO *) PROCEDURE MATCH ; BEGIN (* MATCH *) #MATCHED := TRUE ; #LINE.PTR := 2 ; #EXTRACT(LINE) ; (* REMOVE (C,D,F) *) #IF IMB.LEO^N = LINE.LEN &THEN )FOR I := 1 TO IMB.LEN DO ,MATCHED := MATCHED AND 7(IMB.IMAGE[I] = LINE.IMAGE[I]) )ELSE ,MATCHED := FAL?BEGIN (* REMOVE CORRECT WORD *) @DMB.IMAGE[I] := KMB.IMAGE[I]; @KMB.IMAGE[I] := ' '; ?END ; (* REMOVE CORRECT WORD *) ;ESE ; #GETLN ; END ; (* MATCH *) BEGIN (* TYPE4FRAME *) #HEADERTEXT ; #SAVEBLOCK := LINEBLOCK ; #SAVEBYTE := LINEBYTE ; #RND ; (* WORDS REMAINING *) 2END (* A COMPLETE WORD MATCH *) /ELSE 2BEGIN (* NOT A WORD MATCH *) 5BLANK(IMB); 5BLANK(KEPEAT &KBDIN ; &REPOSITION ; &REPEAT )MATCH &UNTIL MATCHED OR RANEOF OR (COL1 IN ['1'..'4']) ; &IF NOT MATCHED AND (TRIE   BEGIN A[IJ] := A[I]; A[I] := T; T := A[IJ] END END; REPEAT REPEAT L := L - 1  UNTIL A[L] <= T; REPEAT K := K + 1 UNTIL A[K] >= T; IF K <= L THEN  BEGIN TT := A[L]; A[L] := A[K]; A[K] := TT END UNTIL K > L END (* SPLIT *) ; PROCEDURE ISORT; (* REQUIRES A[I-1] LESS THAN OR EQUAL TO ALL VALUES IN A[I..J]; STRAIGHT INSERTION SORT OF A[I..J] *)  BEGIN I := I + 1; WHILE I <= J DO BEGIN T := A[I]; K := I - 1; WHILE A[K] > T DO  BEGIN A[K+1] := A[K]; K := K - 1 END; A[K+1] := T; I := I + 1 END END (* ISORT *) ;  FUNCTION TRIVIAL: BOOLEAN; BEGIN TRIVIAL := (J - I <= 10) AND ((I <> II) OR (I >= J)); END; PROCE PROGRAM QSORTTEST; PROCEDURE QSORT(VAR A: VECTOR; II,JJ: INTEGER); (* QUICKSORT OF A[II..JJ] *) (* SINGLETON,DURE SORT; (* CONTROL PROCEDURE *) VAR IL,IU: INTEGER; BEGIN REPEAT SPLIT;  RICHARD C. ALGORITHM 347. COMM. ACM 12, 3 (MARCH 1969), 185 - 187. *) VAR T,TT: REAL; I,J,IJ,K,L: INTE IF L - I > J - K THEN BEGIN IL := I; IU := L; I := K END ELSE BEGIN IL := K; IU := J;GER; PROCEDURE SPLIT; (* REQUIRES I < J; SPLIT A INTO TWO SEGMENTS A[I..L] AND A[K..J] SUCH THAT ALL J := L END; IF TRIVIAL THEN ISORT ELSE SORT; I := IL; J := IU; UNTIL TRIVIAL;  VALUES IN THE FIRST SEGMENT ARE LESS THAN OR EQUAL TO ALL VALUES IN THE SECOND SEGMENT *) BEGIN IJ := ISORT END (* SORT *) ; BEGIN I := II; J := JJ; IF I < J THEN SORT END (* QSORT *) ; BEGIN (* (I + J) DIV 2; T := A[IJ]; K := I; L := J; IF A[I] > T THEN BEGIN A[IJ] := A[I]; A[I] := T; T := A[IJ] E MAIN PROGRAM *) K := 1; ERR := FALSE; REPEAT & QSORT(A,1,N); K := K + 1 UNTIL (K > 5) OR ERR; WRITELN(' END; IF A[J] < T THEN BEGIN A[IJ] := A[J]; A[J] := T; T := A[IJ]; IF A[I] > T THEN ND OF RUN'); END.  h title 'Output file 2-JUL-78'. based on a program by Brad Blasing. } {[a=15, p=5, i=4, q=1]} { } {$D3} program DecList; const *OutSize = 1000; /BS = 8; /CR = 13; /LF = 10; ,NULLC = 0; $ type +Buffer = array [ 0..300 ] of char; ,Table = array [ - 1..100 ] of integer; *StatusRegister = (b0, b1, b2, b3, b4, b5, b6, ready, b8, b9, b10, b11, b12, 6b13, b14, mr){ DecList : list file on decwriter George Gonzalez 8-JUL-78 DecList uses the Back; -dset = set of StatusRegister; +Device = packed record FInputCSR: dset; HInData: integer; EOutputCSR: dset; DOutputData:Space and linefeed features on a decwriter (or similar terminal) to minimize the time needed to list a file. To use, position the paper in the terminal at the top of a page and type: execute DecList. DecList asks: File: [ Type in the name of the file to be listed ] / options Options can be specified following a "/" :  /P or /P# Pageinate output into pages (# lines long). DecList asks for a page title. /R# Put oa !O^ut # null characters afer a line feed to accomodate slow printers like TTY38 and Terminets. Reasonable values of # are 3 to 9. /C# Overprint each line # times to make a darker copy. /L Set "line printer mode". Columm 1 of the file is interpreted as a line printer control character.  Example: File: outfile/C2, R3, L, P Title: Output file 2-JUL-78 the above command will list file outfile with line printer spacing control, print each 2 times, output 3 nulls and page the output wit   1) mod OutSize; $end {Print}; procedure Twiddle { Print a char (if possible) }; $ $begin (if ready in IoPort ^.OutputC ord(CommandLine [ Column ]) - ord('0'); 4Column := Column + 1; 0end; ,if Place <> Column then 0V := T; ,Column := Column -SR then ,if OutputBuffer [ OutputPointer ] <> Null then 0Print; $end {Twiddle}; procedure SendChar(c: char) { place char 1; (end {GetNumber}; $ $ $ $ $ $begin { ControlStatement } (CommandLine := concat(CommandLine, '.'); (ComLength := len in output Buffer }; $ $begin (repeat ,Twiddle (until OutputBuffer [ InPointer ] = Null; (OutputBuffer [ InPointer ] := c;gth(CommandLine); (Column := 1; (while (Column < ComLength) and (CommandLine [ Column ] <> '/') do ,Column := Column + 1; (i (InPointer := (InPointer + 1) mod OutSize $end {SendChar}; procedure FlushBuffer { wait for output Buffer to empty }; f Column <= ComLength (then ,begin 0while (CommandLine [ Column ] in 7[ 'I', 'L', 'T', 'C', 'R', 'P', ',', '/' ]) 3and (Co$ $begin (while OutputBuffer [ OutputPointer ] <> Null do ,Twiddle; $end {FlushBuffer}; procedure Initialize; $ $varlumn <= ComLength) do 4begin 8case CommandLine [ Column ] of <'I': AIncludes := true; <'L': @LinePrinter := true; <'T':  5p: integer; ( $begin { Initialize } (LineFeed := chr(LF); (BackSpace := chr(BS); (Return := chr(CR); (Null := chr(NULLC@LinePrinter := false; <'C': @GetNumber(Copies); <'R': @GetNumber(Nulls); <'P': @begin DPaging := true; DGetNumber(PageS); (Line [ 0 ] := 'N'; (Title[ 0 ] := 'N'; (LineCount := 1; (LastChar := 1; (LinesRead := 0; (CharsRead := 0; (Size := 0;ize) @end; <',', '/': { } 8end; 8Column := Column + 1; 4end; 0if Paging 0then 4begin { gettitle } 8write('Title:');  char  0 then ,FileName :=rd 9case boolean of =false: ( IoPort: ^ Device); =true: ( i: integer) 5end; .OutputBuffer: array [ 0.. Ou copy(CommandLine, 1, p - 1); (SendChar(Return); $end { Initialize }; procedure ControlStatement; $ $var 2ComLength, tSize ] of char; -InPointer, ,OutputPointer: integer; $ procedure Print { move character to a Device }; $ $begin (IoPo3Column, 5I: integer; ( $ $ $ $ $procedure GetNumber(var V: integer); ( (var 7Place, 9T: integer; , (begin rt ^.OutputData := OutputBuffer [ OutputPointer ]; (OutputBuffer [ OutputPointer ] := Null; (OutputPointer := (OutputPointer +,T := 0; ,Column := Column + 1; ,Place := Column; ,while CommandLine [ Column ] in [ '0' .. '9' ] do 0begin 4T := T * 10 +  = 1 to SkipCount do ,begin 0SendChar(LineFeed); 0for K := 1 to Nulls do 4SendChar(Null); ,end; (LineCount := LineCount + S,Count [ StartLine ] := Count [ StartLine ] - Difference + 1; ,if Count [ StartLine ] < Count [ Backups ] then 0Backups := StkipCount { Skip } $end { Skip }; procedure EjectPage; $ $begin { EjectPage } (Skip(PageSize - (LineCount mod PageSize))artLine; ,StartLine := StartLine + Difference - 1; (end {Find}; $ $ $ $ $ $procedure Backup; ( (var 7Place: integer;  $end { EjectPage }; procedure out(low: integer); $ $var 3Column: integer; ( $begin { out } (for Column := low to S, (begin { } ,for Place := 1 to Backups do 0SendChar(BackSpace); ,out(Min(LastChar, LastChar - Backups)); ,if not NoReturize do ,begin 0SendChar(Line [ Column ]); ,end $end { out }; function Min(v1, v2: integer): integer; $ $begin { Min }n then 0begin { ret } 4SendChar(Return); 4 Size := Count [ Backups ] - 2 * Backups - Size + Min(Size, 7LastChar - 1); 4out( (if v1 < v2 (then ,Min := v1 (else ,Min := v2 $end { Min }; function Max(v1, v2: integer): integer; $ 1); 0end { ret }; (end {}; $ $ $ $ $ $begin { SmartPrint } (StartLine := 1; (HalfLine := LastChar div 2; (if Size > 0$begin { Max } (if v1 > v2 (then ,Max := v1 (else ,Max := v2 $end { Max }; procedure CarriageControl; $ $ $ $ $ (then ,begin { notnull } 0while (Line [ StartLine ] = ' ') and (StartLine <= Size ) do 4StartLine := StartLine + 1; 0NoRet $procedure LineControl; ( (var 7Place: integer; , (begin { LineControl } ,if Line [ 1 ] in [ ' ', '1', '0', '+' ] then urn := StartLine > HalfLine; 0if NoReturn 0then 4Backups := LastChar - StartLine 0else 4begin { Return } 8Backups := - 1; 0case Line [ 1 ] of 4'+': 8Skip(0); 4' ': 8Skip(1); 4'0': 8Skip(2); 4'1': 8EjectPage; 0end; ,Size := Size - 1; ,for P8Count [ Backups ] := Size; 8StartLine := Backups; 8while StartLine < HalfLine do  - 1) or NoReturn 0then 4Backup 0else 4begin { simple } 8SendChar(Return); 8out(1) 4end { simple }; 0Las(if LinePrinter (then ,LineControl (else ,Skip(1) $end { CarriageControl }; procedure SmartPrint { determine optimal ftChar := Size + 1 ,end { notnull } $end { SmartPrint }; procedure List( Deeper : boolean ); $forward; procedure Ex8readln(CommandLine); 8TitleLength := 15; 8for I := 1 to TitleLength do  Size - 5 ) or Okay; ,if Okay ,then 0i(procedure ReadLine; , ,begin { ReadLine } 0 Size := 0; 0while not (eof(F) or eoln(F)) do 4begin 8Size := Size + 1; 8Linf Line [ Start + 2 ] in [ 'I', 'i' ] 0then 4begin 8Start := Start + 3; 8Fn := ' '; 8whie [ Size ] := F ^; 8get(F); 8Twiddle; 4end; 0CharsRead := CharsRead + Size ; 0LinesRead := LinesRead + 1; 0if eoln(F) thenle Line [ Start ] = ' ' do <Start := Start + 1; 8Ending := Start; 8while (Line [ Ending ] <> '}') and ( Ending < size ) do  4get(F) ,end { ReadLine }; ( ( ( ( ( (begin { GetInputLine } ,PagePosition := LineCount mod PageSize; ,if Paging ,th<Ending := Ending + 1; 8repeat ;Ending := Ending - 1 ; 8until Line[Ending] <> ' '; ; <for I := Start to Ending do @Fn [ I en 0begin { paging } 4if PagePosition = TopMargin 4then 8begin <Line := Title; <Size := TitleLength 8end 4else ���������- Start + 1 ] := Line [ I ]; 4end; ( end; (end {Getname}; $ $ $ $ $ $begin {List} (GetName; (if Fn = '' (then ,fo8if (PagePosition < TopOfPage) 8or (PagePosition > (PageSize - BottomMargin)) 8then < Size := 0 8else <ReadLine; 0end { pr CopyCount := 1 to Copies do 0SmartPrint (else ,Expand(Fn, Line, FileThere); $end {List}; begin { DecList } $Initialiaging } ,else 0ReadLine; ,for Fill := Size + 1 to LastChar do 0Line [ Fill ] := ' '; ,while Line [ Size ] = ' ' do 0 Size ze; $ControlStatement; $Expand(FileName, Line, Success); $if Success then $begin *EjectPage; *FlushBuffer; end;  end := Size - 1; (end { GetInputLine }; $ $ $ $ $ $begin {$I-} (Close(F); (Reset(F, FileName); (if IOresult <> 0 then ,be{ DecList }. �������������������������������������������������������������������������������������������������������������������gin 0Close(F); 0Reset(F, Concat(FileName, '.TEXT')); ,end; {$I+} (if Size > 0 then (begin .Line := RawLine; .List( false �); (end; (Found := IOResult = 0; (if Found then ,begin 0While not EOF(F) do 4begin 8GetInputLine; 8CarriageControl; 8Li�st( Includes ); 4end; ,end; (Close(F); $end {Expand}; procedure List{ Deeper : boolean }; $ $var 4FileThere: boolean�; 4CopyCount:integer; 6Fn: string; ( $ $ $ $ $procedure Getname; ( (var 9I, Start, Ending: integer; , (function Oka���� OOLEAN; PROCEDURE GETCHAR; BEGIN "J := J+1; (* J IS THE INDEX INTO THE SOURCE STRING *) "IF J<=LENGTH(SOURCE) %THEN (CP(IDTEXT: IDKIND): INTEGER; VAR I: INTEGER; BEGIN "I := TOTALIDS; "NAMETABLE[0].NAME := IDTEXT; "(* NOTE DON'T CHANGE H := SOURCE[J] �����������������������������������������������������������������������������������������������������������������THIS AS THIS FACT IS USED INSIDE OF PRIMARY!!!!!!! *) "WHILE NAMETABLE[I].NAME<>IDTEXT DO %I := I-1; "LOOKUP := I END (* %ELSE (CH := '#'; (* EOF SOURCE CHAR *) "IF (CH>='a') AND (CH<='z') %THEN (CH := CHR(ORD(CH)-32) (*CHANGE TO UPPER CASE*) OF LOOKUP *); BEGIN (*GETID*) "ID := IDBLANKS; "I := 0; "REPEAT %IF I<=IDLENGTH (THEN +ID[I] := CH; %I := I+1; %GETCH�END (* OF GETCHAR *); PROCEDURE SCANNER; VAR DONTEAT: BOOLEAN; PROCEDURE GETCONSTANT; (* Real number scanner RJH 9 �July 77 *) VAR WHOLEPART: REAL; #DODECIMAL: BOOLEAN; FUNCTION NUMBER (FRACTION: BOOLEAN): REAL; (* Returns number as �whole or fraction *) VAR SUM, COUNT: REAL; BEGIN "COUNT := 1; "SUM := 0; "REPEAT %IF SUM < 0.9E37 (*MAXREAL*) (THEN +�BEGIN .SUM := 10*SUM + ORD(CH) - ORD('0'); .COUNT := 10*COUNT +END; %GETCHAR "UNTIL NOT (CH IN NUMERIC); "IF FRACTION %TH PROGRAM CALCULATOR;(* WRITTEN BY DALE ANDER JULY 8, 1977 *) (* CHANGED TO A CALCULATOR ON JULY 17, 1977 *) CONST IDEN (NUMBER := SUM / COUNT %ELSE (NUMBER := SUM END (*NUMBER*); BEGIN (*GETCONSTANT*) "TOKENTYPE := CONSTV; "IF CH <> 'LENGTH = 7; %TABLESIZE = 35; (* INCREASE TABLESIZE FOR MORE MEMORY *) %IDBLANKS = ' '; %LASTX = 'LASTX '; TYPE .' %THEN (BEGIN +WHOLEPART := NUMBER(FALSE); +IF CH='.' .THEN 1GETCHAR; +DODECIMAL := (CH IN NUMERIC); (END %ELSE (BEG TOKENKINDS = (CONSTV, EOFV, FUCIDENV, LINEV, LPARENV, MINUSV, 4PLUSV, 4RPARENV, SLASHV, STARV, UNRECIDV, UNRECSYMV, 4UPARROIN �����������������������������������������������������������������������������������������������������������������������������WV, 4VARIDENV, EQUALV, LASTXV); $IDKIND = PACKED ARRAY[0..IDLENGTH] OF CHAR; VAR CH: CHAR; #J, TOTALIDS, INDEX: INTEGER;+WHOLEPART := 0; +GETCHAR; +DODECIMAL := (CH IN NUMERIC); +IF NOT DODECIMAL .THEN 1TOKENTYPE := UNRECSYMV (END; "IF DODE #OPERATORS, ALPHA, NUMERIC: SET OF CHAR; #NUM, ANSWER: REAL; #SOURCE: STRING; #TOKENTYPE: TOKENKINDS; #NAMETABLE: ARRAY[0.CIMAL %THEN (NUM := WHOLEPART + NUMBER(TRUE) %ELSE (NUM := WHOLEPART; "DONTEAT := CH<>' '; "(* DONT EAT NEXT NONBLANK IF C.TABLESIZE] OF .RECORD 1NAME: IDKIND; 1CASE ISVAR: BOOLEAN OF 4TRUE: (VALUE: REAL) .END; #TEMP: REAL; #ITSOK, GAVEERR: BH IS NONBLANK DA 7/11/77 *) END (* OF GETCONSTANT *); PROCEDURE GETID; VAR ID: IDKIND; #I: INTEGER; FUNCTION LOOKU��� TYPE := EQUALV; 7'#': BEGIN ?TOKENTYPE := EOFV; ?DONTEAT := TRUE <END 4END 1ELSE 4TOKENTYPE := UNRECSYMV; "IF NOT DONTEAEGIN "EVALU8 := TRUE; "IF PARENEXPRESSION (ARG) %THEN (CASE FUCNUM OF +1: ANS := SIN(ARG); +2: ANS := COS(ARG); +3: IF COT %THEN (REPEAT +GETCHAR (UNTIL CH<>' ' (* GETNONBLANK *) END (* OF SCANNER *); FUNCTION EXPRESS(VAR ANS: REAL): BOOLEAS(ARG)=0 1THEN 4BEGIN 7WRITE('Undefined TAN'); 7GAVEERR := TRUE 4END 1ELSE 4ANS := SIN(ARG)/COS(ARG); +4: IF ARG<=0 1THN ; ����������������������������������������������������������������������������������������������������������������������������EN 4BEGIN 7WRITE('Undefined LOG'); 7GAVEERR := TRUE 4END 1ELSE 4ANS := LOG(ARG); +5: IF ARG<=0 1THEN 4BEGIN 7WRITE('Un VAR OK, CHANGESIGN: BOOLEAN; #RSLT1, RSLT2: REAL; #SAVEOP: TOKENKIND; FUNCTION TERM(VAR ANS: REAL): BOOLEAN ; VAR OK:defined LN'); 7GAVEERR := TRUE 4END 1ELSE 4ANS := LN(ARG); +6: ANS := ABS(ARG); +7: IF ARG<0 1THEN 4BEGIN 7WRITE('Undef BOOLEAN; #SAVEOP: TOKENKIND; #RSLT1, RSLT2: REAL; FUNCTION FACTOR(VAR ANS: REAL): BOOLEAN ; VAR OK: BOOLEAN; #RSLT1, Rined SQRT'); 7GAVEERR := TRUE 4END 1ELSE 4ANS := SQRT(ARG); +10: IF (ROUND(ARG)>33) OR (ROUND(ARG)<0) 2THEN 5BEGIN 8WRITSLT2: REAL; FUNCTION PRIMARY(VAR ANS: REAL): BOOLEAN ; (* REWRITTEN BY RJH 12 JULY 77 *) (* REREWRITTEN BY D ANDER 7/14/E('Cannot calculate factorial GTR 33'); ����������������������������������������������������������������������������������������AR "UNTIL NOT(CH IN ['A'..'Z','0'..'9']); "DONTEAT := CH<>' '; (* DONT GET NEXT NONBLANK IF CH IS NONBLANK *) "IF ID=LASTX %77 *) VAR FUCNUM, SAVEINDEX: INTEGER; #SAVEID: IDKIND; #SAVETOK: TOKENKINDS; FUNCTION PARENEXPRESSION(VAR ANS: REAL): BTHEN ���������������������������������������������������������������������������������������������������������������������������OOLEAN ; BEGIN "PARENEXPRESSION := FALSE; "IF TOKENTYPE=LPARENV %THEN (BEGIN +SCANNER; +IF EXPRESS(ANS) .THEN 1IF TOKE(TOKENTYPE := LASTXV %ELSE (BEGIN +INDEX := LOOKUP(ID); +IF INDEX>0 .THEN 1IF NAMETABLE[INDEX].ISVAR 4THEN 7TOKENTYPE :NTYPE=RPARENV 4THEN 7BEGIN :SCANNER; :PARENEXPRESSION := TRUE 7END 4ELSE 7IF TOKENTYPE<>EOFV :THEN =BEGIN >GAVEERR := = VARIDENV 4ELSE 7TOKENTYPE := FUCIDENV .ELSE 1TOKENTYPE := UNRECIDV (END END (* OF GETID *); BEGIN (*SCANNER*) "DONTTRUE; >WRITE ('Right parenthesis missing') =END (END %ELSE (IF TOKENTYPE IN [UNRECIDV, UNRECSYMV] +THEN .BEGIN 1GAVEERR EAT := FALSE; "IF CH IN ALPHA %THEN (GETID %ELSE (IF CH IN NUMERIC+['.'] +THEN .GETCONSTANT +ELSE .IF CH IN OPERATORS := TRUE; �����������������������������������������������������������������������������������������������������������������������1THEN 4CASE CH OF 7'+': TOKENTYPE := PLUSV; 7'-': TOKENTYPE := MINUSV; 7'*': TOKENTYPE := STARV; 7'/': TOKENTYPE := SLASHV;1WRITE ('Illegal symbol') .END +ELSE .IF TOKENTYPE<>EOFV 1THEN 4BEGIN 7GAVEERR := TRUE; 7WRITE ('Left parenthesis missin 7'\': TOKENTYPE := LINEV; 7'^': TOKENTYPE := UPARROWV; 7'(': TOKENTYPE := LPARENV; 7')': TOKENTYPE := RPARENV; 7'=': TOKENg') 4END END (* OF PARENEXPRESSION *); FUNCTION EVALU8 (VAR ANS: REAL): BOOLEAN; VAR ARG, TEMP: REAL; #I: INTEGER; B��� 1(* THIS WAS PUT THERE BY LOOKUP IN GETID *) 1SAVEINDEX := INDEX; (*GLOBAL SET IN GETID*) 1(*THIS MAY NOT BE NECESSARY*) 1SCA4END 1ELSE 4OK := FALSE +END (ELSE +OK := FALSE; "IF OK %THEN (ANS := RSLT1; "FACTOR := OK END (* OF FACTOR *); BNNER; 1IF TOKENTYPE=EQUALV 4THEN (* MEMORY ASSIGNMENT *) 7BEGIN :SCANNER; :IF EXPRESS(ANS) =THEN >BEGIN ?IF SAVETOK=UNREGIN (*TERM*) "OK := TRUE; "IF FACTOR(RSLT1) %THEN (WHILE OK AND (TOKENTYPE IN [STARV, SLASHV, LINEV]) DO +BEGIN .SAVEOP :ECIDV @THEN AIF TOTALIDS+1<=TABLESIZE BTHEN CBEGIN DTOTALIDS := TOTALIDS+1; DSAVEINDEX := TOTALIDS; DWITH NAMETABLE[SAVEI= TOKENTYPE; .SCANNER; .IF FACTOR(RSLT2) 1THEN 4CASE SAVEOP OF 7STARV: RSLT1 := RSLT1*RSLT2; 7SLASHV: IF RSLT2=0 @THEN ANDEX] DO �����������������������������������������������������������������������������������������������������������������������BEGIN BOK := FALSE; BGAVEERR := TRUE; BWRITE('Division by zero') AEND @ELSE ARSLT1 := RSLT1/RSLT2; 7LINEV: IF ROUND(RSLT2EBEGIN FISVAR := TRUE; FNAME := SAVEID EEND CEND BELSE CBEGIN DWRITE( F'Table full. Assignment not done' D); DGAVEERR)=0 ?THEN @BEGIN AOK := FALSE; AGAVEERR := TRUE; AWRITE('MOD by zero') @END ?ELSE @RSLT1 := ROUND(RSLT1) MOD ROUND(RSLT2 := TRUE CEND; ?IF SAVEINDEX<>0 @THEN ABEGIN BNAMETABLE[SAVEINDEX].VALUE := ANS; BPRIMARY := TRUE AEND >END 7END 4ELS) 4END (* OF CASE *) 1ELSE 4OK := FALSE +END (ELSE +OK := FALSE; "IF OK %THEN (ANS := RSLT1; "TERM := OK END (* OF TE 7IF SAVETOK=UNRECIDV :THEN =BEGIN >WRITE('Unrecognized ID'); >GAVEERR := TRUE =END :ELSE =BEGIN >PRIMARY := TRUE; >AERM *); ������������������������������������������������������������������������������������������������������������������������NS := NAMETABLE[SAVEINDEX].VALUE =END .END +ELSE .IF TOKENTYPE=FUCIDENV 1THEN (*FUNCTION*) 4BEGIN 7FUCNUM := INDEX; (*IND BEGIN (*EXPRESS*) "OK := TRUE; "IF TOKENTYPE IN [PLUSV,MINUSV] %THEN (BEGIN +CHANGESIGN := (TOKENTYPE=MINUSV); +SCANNEEX SET BY GETIDENT*) 7SCANNER; 7PRIMARY := EVALU8 (ANS) 4END 1ELSE 4IF TOKENTYPE=LASTXV 7THEN :BEGIN =SCANNER; =ANS := R (END %ELSE (CHANGESIGN := FALSE; "IF TERM(RSLT1) %THEN (BEGIN +IF CHANGESIGN .THEN 1RSLT1 := -RSLT1; +WHILE OK AND (8GAVEERR := TRUE 5END 2ELSE 5BEGIN 8TEMP := 1; 8FOR I:=2 TO ROUND(ARG) DO ;TEMP := TEMP*I; 8ANS := TEMP 5END (END (* OANSWER; =PRIMARY := TRUE :END 7ELSE :PRIMARY := PARENEXPRESSION (ANS) END (* OF PRIMARY *); BEGIN (*FACTOR*) "OK := TRF CASE *) %ELSE (EVALU8 := FALSE; "IF GAVEERR %THEN (EVALU8 := FALSE END (* OF EVALU8 *); BEGIN (*PRIMARY*) "PRIMARY UE; "IF PRIMARY(RSLT1) %THEN (WHILE OK AND (TOKENTYPE=UPARROWV) DO +BEGIN .SCANNER; .IF PRIMARY(RSLT2) 1THEN 4BEGIN 7IF:= FALSE; "IF TOKENTYPE=CONSTV %THEN (*CONSTANT*) (BEGIN +ANS := NUM; (*GLOBAL SET BY GETCONSTANT*) +PRIMARY := TRUE; +SCA RSLT1<=0 ����������������������������������������������������������������������������������������������������������������������NNER (END %ELSE (IF TOKENTYPE IN [VARIDENV, UNRECIDV] +THEN .BEGIN 1SAVETOK := TOKENTYPE; 1SAVEID := NAMETABLE[0].NAME; :THEN =BEGIN >WRITE('Cannot calculate power'); >OK := FALSE; >GAVEERR := TRUE =END :ELSE =RSLT1 := EXP(RSLT2*LN(RSLT1)) ��� T1 := RSLT1+RSLT2; :MINUSV: RSLT1 := RSLT1-RSLT2 7END 4ELSE 7OK := FALSE .END (END %ELSE (OK := FALSE; "EXPRESS := OK; %SCANNER; %ITSOK := EXPRESS(TEMP) AND (TOKENTYPE=EOFV); %IF NOT ITSOK (THEN +BEGIN .IF (TOKENTYPE=EOFV) AND NOT GAVEERR 1"IF OK %THEN (ANS := RSLT1 END (* OF EXPRESS *); PROCEDURE INITABLES; BEGIN "ALPHA := ['A'..'Z']; "NUMERIC := ['0'..THEN 4WRITE ('Unexpected end of expression') 1ELSE 4IF NOT GAVEERR 7THEN :WRITE('Illegal Symbol'); .WRITELN(': Try Again')'9']; "OPERATORS := ['+','=','*','-','/','\','^','(',')','#']; "WITH NAMETABLE[1] DO %BEGIN (NAME := 'SIN '; (ISVAR :=  +END (ELSE +BEGIN .WRITELN(' ',TEMP); .ANSWER := TEMP +END "UNTIL FALSE; END (*EXPRESSION*). ����������������������FALSE %END; "WITH NAMETABLE[2] DO %BEGIN (NAME := 'COS '; (ISVAR := FALSE %END; "WITH NAMETABLE[3] DO %BEGIN (NAME �:= 'TAN '; ������������������������������������������������������������������������������������������������������������������(ISVAR := FALSE %END; "WITH NAMETABLE[4] DO %BEGIN (NAME := 'LOG '; (ISVAR := FALSE %END; "WITH NAMETABLE[5] DO %BE�GIN (NAME := 'LN '; (ISVAR := FALSE %END; "WITH NAMETABLE[6] DO %BEGIN (NAME := 'ABS '; (ISVAR := FALSE %END; �"WITH NAMETABLE[7] DO %BEGIN (NAME := 'SQRT '; (ISVAR := FALSE %END; "WITH NAMETABLE[8] DO %BEGIN (NAME := 'E ';� (ISVAR := TRUE; (VALUE := 2.718282 %END; "WITH NAMETABLE[9] DO %BEGIN (NAME := 'PI '; (ISVAR := TRUE; (VALUE := 3.�141593 %END; "WITH NAMETABLE[10] DO %BEGIN (NAME := 'FAC '; (ISVAR := FALSE %END; "TOTALIDS := 10 (* BUILD IN NUMBER �OF FUNCTIONS AND VARIABLES *) END (* OF INITABLES *); BEGIN (*CALCULATOR*) "ANSWER := 0; "INITABLES; "REPEAT %GAVEERR :�= FALSE; %J := 0; %WRITE('->'); %READLN(SOURCE); %IF LENGTH(SOURCE)=0 (THEN +EXIT(PROGRAM); %REPEAT (GETCHAR %UNTIL CH<�TOKENTYPE IN [PLUSV, MINUSV]) DO .BEGIN 1SAVEOP := TOKENTYPE; 1SCANNER; 1IF TERM(RSLT2) 4THEN 7CASE SAVEOP OF :PLUSV: RSL>' '; (*GETNONBLANK*) ������������������������������������������������������������������������������������������������������������� EAN) ; �������������������������������������������������������������������������������������������������������������������������IMAGE[PTR] <> ')' 5THEN 8BADCDF ; /END ; (* CDF *) )J := 0 ; )FOR I := PTR+1 TO LEN DO ,BEGIN (* REM *) /J := J + 1 ; /BEGIN #WRITELN ; #WRITELN( STARS, ETEXT, STARS ) ; #P(LINE) ; #IF ABORT &THEN )EXIT(CALLS) &ELSE )READLN ; END ; (* ERROIMAGE[J] := IMAGE[I] ; ,END ; (* REM *) )LEN := J ; &END ; (* LW *) END ; (* EXTRACT *) PROCEDURE SETVAL( VAR X : INTEGER ) �R *) PROCEDURE AT( Y, X : INTEGER ) ; (* POSITION CURSOR *) BEGIN #WRITE(OUTPUT, CHR(30), CHR(31+X), CHR(31+Y)) ; END ; (* AT �*) FUNCTION DIGIT(N : INTEGER) : CHAR ; (* RETURN BOTTOM DIGIT *) BEGIN #DIGIT := CHR(N MOD 10 + ORD('0')) ; END ; (* DIGIT *)� PROCEDURE SETS(S : STRING; VAR ST : STR) ; (* MOVE S TO ST *) VAR I : INTEGER ; BEGIN (* SETS *) #ST.LEN := LENGTH(S) ; #ST�.PTR := 0 ; #IF ST.LEN > 0 &THEN )MOVELEFT(S[1], ST.IMAGE, ST.LEN) ; END ; (* SETS *) FUNCTION NEXTNUMBER( VAR L : STR ) : I PROCEDURE CONVERT(VAR FROM : STR; VAR DEST : STRING) ; (* STR --> STRING *) BEGIN (*$R-*) #MOVELEFT(FROM.IMAGE, DEST[1], FROM.NTEGER ; (* RETURN NEXT NEXTNUMBER IN LINE *) VAR X : INTEGER ; BEGIN #WITH L DO &BEGIN )X := 0 ; )WHILE (PTR < LEN) AND (NLEN) ; #MOVELEFT(FROM.LEN, DEST[0], 1) ; (*$R+*) END ; (* CONVERT *) FUNCTION MAX(I, J : INTEGER) : INTEGER ; BEGIN #IF I > JOT (IMAGE[PTR] IN ['0'..'9'])) DO ,PTR := SUCC(PTR) ; )WHILE (PTR <= LEN) AND (IMAGE[PTR] IN ['0'..'9']) DO ,BEGIN /X := X  &THEN )MAX := I &ELSE )MAX := J ; END ; (* MAX *) PROCEDURE UPPERCASE(VAR S, D : STRING) ; (* CONVERT TO UPPER CASE *) VA* 10 + ORD(IMAGE[PTR]) - ORD('0') ; ��������������������������������������������������������������������������������������������R I : INTEGER ; BEGIN #D := S ; #FOR I := 1 TO LENGTH(S) DO &IF D[I] IN ['a'..'z'] )THEN ,D[I] := CHR(ORD(D[I]) - ORD('a') /PTR := SUCC(PTR) ; ,END ; &END ; #NEXTNUMBER := X ; END ; PROCEDURE EXTRACT(VAR L : STR) ; (* EXTRACT (C,D,F) *) VAR I, J+ ORD('A') ) ; END ; (* UPPERCASE *) PROCEDURE P(S : STR) ; (* PRINT S WITH NAME REPLACEMENT *) VAR PS : INTEGER ; $L, UL : S : INTEGER ; PROCEDURE BADCDF ; BEGIN #ERROR('Bad (c,d)', FALSE) END ; BEGIN (* EXTRACT *) #WITH L DO &BEGIN )GOTOCH := 0 TRING ; BEGIN #CONVERT(S, L) ; (* MAKE A TERAK STRING *) #PS := POS('#NAME#',L ) + POS('#name#', L) ; #IF PS > 0 &THEN )BEG; )GOTODRILL := 0 ; )GOTOFRAME := 0 ; )IF IMAGE[PTR] = '(' ,THEN /BEGIN (* CDF *) 2GOTOCH := NEXTNUMBER(L) ; 2IF IMAGE[PTIN ,DELETE(L, PS, 6) ; ,INSERT(FIRSTNAME, L, PS) ; )END ; #WRITELN(L) ; END ; PROCEDURE ERROR(ETEXT : STRING ; ABORT : BOOLR] = ',' 5THEN 8GOTODRILL := NEXTNUMBER(L) 5ELSE 8BADCDF ; 2IF IMAGE[PTR] = ',' 5THEN 8GOTOFRAME := NEXTNUMBER(L) ; 2IF ��� ITION( CHAPTER, DRILL : INTEGER) ; FORWARD ; PROCEDURE DOFRAME ; FORWARD ; PROCEDURE JUMP(C, D : INTEGER ) ; (* JUMP TO (C,D)  #SETS('Very good.', OKSTR) ; #SETS('No, try again.', NOSTR) ; #SETS('The correct answer is:', GIVEUPSTR) ; #SETS('You must *) �����������������������������������������������������������������������������������������������������������������������������restart this drill', RETURNSTR) ; #SETS('Good-bye, #name#.', BYESTR) ; #SETS('', HINTSTR) ; #MAXTRIES := 4 ; #MAXRPT := 4 ; BEGIN #POSITION(C, D) ; #EXIT(DOFRAME) ; (* SKIP REST OF FRAME *) END ; (* NEVER RETURNS *) PROCEDURE GUCOM ; (* PROCESS .G C#MAXSKIP := 6 ; #TESTMODE := FALSE ; END ; (* INIT *) PROCEDURE PROCGOTO ; (* PROCESS GOTO COMMAND *) BEGIN END; (* PROCGOTO OMMAND *) BEGIN #IMB.PTR := 1 ; #GOTOCH := NEXTNUMBER(IMB) ; #GOTODRILL := NEXTNUMBER(IMB) ; #GOTOFRAME := NEXTNUMBER(IMB) ;*) PROCEDURE PROCIF ; (* PROCESS IF STATEMENT *) BEGIN END ; (* PROCIF *) PROCEDURE PROCRESUME ; (* PROCESS RESUME STATEMENT * #JUMP(GOTOCH, GOTODRILL) ; END ; PROCEDURE FUCOM ; (* PROCESS .F COMMAND *) BEGIN #JUMP(VAL^.FURCHAPTER, VAL^.FURDRILL) ; EN) ������������������������������������������������������������������������������������������������������������������������������; (* SET X TO INTEGER *) VAR I : INTEGER ; BEGIN #WITH LINE DO &BEGIN )IF IMAGE[PTR] = '=' ,THEN /PTR := SUCC(PTR) ,ELSE D ; (* FUCOM *) PROCEDURE SUCOM ; (* PROCESS .S COMMAND *) BEGIN #NOTIMP END ; PROCEDURE DUCOM ; (* PROCESS .D COMMAND *) BEG/ERROR('"=" EXPECTED', FALSE) ; �����������������������������������������������������������������������������������������������IN #NOTIMP END ; PROCEDURE HUCOM ; (* PROCESS .H COMMAND *) BEGIN #AT(22,5) ; #IF HINTSTR.LEN > 0 &THEN )P(HINTSTR) &ELSE)X := NEXTNUMBER(LINE) ; &END ; END ; PROCEDURE SETTEXT(VAR DEST : STR) ; (* SET TEXT STRING *) VAR I : INTEGER ; BEGIN #IF )FLASH('No hint!') ; END ; (* HUCOM *) PROCEDURE DODRILLS ; FORWARD ; PROCEDURE CUCOM ; (* PROCESS .C COMMAND *) BEGIN #NOT LINE.IMAGE[LINE.PTR] <> '=' &THEN )ERROR('Bad string', FALSE) ; #DEST.LEN := 0 ; #FOR I := LINE.PTR+1 TO LINE.LEN DO &WITHIMP END ; PROCEDURE USERCOM ; (* PROCESS USER COMMAND *) BEGIN #IF (IMB.IMAGE[1] = '.') AND (IMB.LEN > 1) &THEN )CASE IMB.I DEST DO )BEGIN ,LEN := LEN + 1 ; ,IMAGE[LEN] := LINE.IMAGE[I] ; )END ; END ; (* SETTEXT *) PROCEDURE FLASH(S : STRING) ; (MAGE[2] OF ���������������������������������������������������������������������������������������������������������������������* FLASH A MESSAGE *) VAR I : INTEGER ; BEGIN #WRITE(OUTPUT, S) ; #FOR I := 1 TO DELAY DO (* WAIT *) ; #FOR I := 1 TO LENGTH(,'Q','q' : EXIT(DODRILLS) ; ,'G','g' : GUCOM ; ,'F','f' : FUCOM ; ,'S','s' : SUCOM ; ,'D','d' : DUCOM ; ,'H','h' : HUCOM ;S) DO &WRITE(CHR(BS)) ; #FOR I := 1 TO LENGTH(S) DO &WRITE(' ') ; #FOR I := 1 TO LENGTH(S) DO &WRITE(CHR(BS)) ; END ; (* FL ,'C','c' : CUCOM )END ; (* CASE *) END ; (* USERCOM *) PROCEDURE KBDIN ; (* PROCESS KEYBOARD INPUT *) BEGIN #REPEAT &AT(12ASH *) PROCEDURE NOTIMP ; BEGIN #AT(22,20) ; #FLASH('That command is not yet working!!!') ; END ; (* NOTIMP *) PROCEDURE POS,1) ; &KBDLINE(IMB) ; &USERCOM ; #UNTIL IMB.IMAGE[1] <> '.' ; END ; (* KBDIN *) PROCEDURE INIT ; (* INITIALIZE VARS *) BEGIN��� ELSE )IF KEYWORD = 'IF' ,THEN /PROCIF ,ELSE /IF KEYWORD = 'RESUME' 2THEN 5PROCRESUME 2ELSE 5IF KEYWORD = 'OK' 8THEN ;L ; &UNTIL (COL1 <> '*') OR RANEOF ; &IF NOT (COL1 IN ['1', '2', '3', '4', ' ', '+', '>', '$']) )THEN ,BEGIN (* BADL *) /WSETTEXT(OKSTR) 8ELSE ;IF KEYWORD = 'NO' >THEN ?SETTEXT(NOSTR) >ELSE ?IF KEYWORD = 'GIVEUP' @THEN ASETTEXT(GIVEUPSTR) @ERITELN('Invalid text line:') ; /P(LINE) ; ,END ; (* BADL *) &IF COL1 = '$' )THEN ,COMMAND ; #UNTIL (COL1 IN ['1', '2', '3'LSE ����������������������������������������������������������������������������������������������������������������������������, '4', ' ', '+', '>']) OR RANEOF ; END ; (* GETLN *) PROCEDURE FIND(NEWDRILL : INTEGER) ; (* Find next drill in directory *) VAIF KEYWORD = 'RETURN' BTHEN CSETTEXT(RETURNSTR) BELSE CIF KEYWORD = 'BYE' DTHEN ESETTEXT(BYESTR) DELSE EIF KEYWORD = 'AR LOWER, UPPER, DIFF, NEWVAL : INTEGER ; $MATCH : BOOLEAN ; BEGIN #WITH DIRECTORY^ DO &BEGIN )LOWER := 1 ; )UPPER HINT' FTHEN GSETTEXT(HINTSTR) FELSE GIF KEYWORD = 'TRIES' HTHEN ISETVAL(MAXTRIES) HELSE IIF KEYWORD = 'REPEAT' JTHEN K:= DIRSIZE ; )REPEAT ,PROBE := TRUNC((LOWER+UPPER) DIV 2) ; ,WITH DIRDATA[PROBE] DO /DIFF := NEWDRILL - FDRILL ; ,MATCH := SETVAL(MAXRPT) JELSE KIF KEYWORD = 'SKIP' LTHEN MSETVAL(MAXSKIP) LELSE MIF KEYWORD = 'TEST' NTHEN OTESTMODE := TRUE NEL( UPPER < LOWER ) OR ( DIFF = 0 ) ; ��������������������������������������������������������������������������������������������SE OERROR( Q'Unknown CALLS command' U, FALSE) ; END ; (* COMMAND *) PROCEDURE GETFL ; (* READ CONTINUATION LINES *) PROCEDU,IF DIFF < 0 /THEN 2UPPER := PROBE - 1 ; ,IF DIFF > 0 /THEN 2LOWER := PROBE + 1 ; )UNTIL MATCH ; )IF DIFF <> 0 ,THEN /RE RNL ; (* READ NEXT LINE, SAVE PLACE *) BEGIN #NLBLOCK := RESBLK ; #NLBYTE := BUFPTR ; #GETRANLINE(NEXT) ; END ; (* RNL *) BEGIN (* ADJUST *) 2IF PROBE <= 0 5THEN 8PROBE := 1 5ELSE 8IF PROBE >= DIRSIZE ;THEN >PROBE := DIRSIZE ;ELSE >IF DIFF >BEGIN #WITH VAL^, DIRECTORY^.DIRDATA[DRILLINDEX] DO &IF (FURCHAPTER > RESCHAPTER) OR )((FURCHAPTER = RESCHAPTER) AND (FURDRIL BEGIN (* GETFL *) #IF EMPTY &THEN )RNL ; #EMPTY := FALSE ; #LINE := NEXT ; #COL1 := LINE.IMAGE[1] ; #LINEBLOCK := NLBLOCL > FDRILL)) )THEN ,JUMP(FURCHAPTER, FURDRILL) ; END ; (* PROCRESUME *) PROCEDURE COMMAND ; (* PROCESS $ COMMAND *) VAR KEY K ; #LINEBYTE := NLBYTE ; #RNL ; #WHILE (NEXT.IMAGE[1] = '+') AND (NEXT.LEN > 0) DO &BEGIN (* RNL *) )NEXT.IMAGE[1] := ' ' : STRING ; BEGIN (* COMMAND *) #LINE.PTR := 2 ; #KW.LEN := 0 ; #WITH LINE DO &BEGIN (* L *) )WHILE (PTR <= LEN) AND (IMAGE[; ������������������������������������������������������������������������������������������������������������������������������PTR] IN ['A'..'Z', 'a'..'z']) DO ,BEGIN (* ACC *) /KW.LEN := KW.LEN + 1 ; /KW.IMAGE[KW.LEN] := IMAGE[PTR] ; /PTR := SUCC(PTR)FOR I := 1 TO NEXT.LEN DO ,WITH LINE DO /BEGIN (* CL *) 2LEN := LEN + 1 ; 2IMAGE[LEN] := NEXT.IMAGE[I] ; /END ; (* CL *) ) ; ,END (* ACC *) &END ; (* L *) #CONVERT(KW, KEY) ; #UPPERCASE(KEY,KEYWORD) ; #IF KEYWORD = 'GOTO' &THEN )PROCGOTO &)RNL ; &END ; (* RNL *) END ; (* GETFL *) PROCEDURE GETLN ; (* READ RANDOM LINE INTO 'LINE' *) BEGIN #REPEAT &REPEAT )GETF��� ITE( RESCHAPTER, '.', FDRILL, '.', RELFRAME ) ; ,IF HINTSTR.LEN > 0 /THEN 2WRITELN(' (Hint available)') /ELSE 2WRITELN ;  P : INTEGER ; BEGIN #GET(VAL) ; #IF VAL^.PASSWORD <> PW &THEN )ERROR('Invalid validation file', FALSE) ; #FIRSTNAME := VAL,WRITELN ; ,LINE.IMAGE[1] := CHR(0) ; ,REPEAT /P(LINE) ; /GETLN ; /LINE.IMAGE[1] := CHR(0) ; ,UNTIL (COL1 <> ' ') OR RANEO^.STUDENTNAME ; #P := POS(' ', FIRSTNAME) ; #IF P > 0 &THEN )FIRSTNAME := COPY(FIRSTNAME, 1, P-1) ; END ; (* VALIDATE *) PRF ; ,IF RANEOF /THEN 2P(NEXT) ; )END ; (* TXTOUT *) END ; (* HEADERTEXT *) PROCEDURE WINDUP ; VAR VALNEW : FILE OF VALOCEDURE FETCH(CHAP : INTEGER) ; (* LOCATE CHAPTER FILE *) VAR CHAPNAME, DIRNAME, TEXTNAME, $CHNUM : STRING ; $CN : STR ; REC ; ��������������������������������������������������������������������������������������������������������������������������$ERR : BOOLEAN ; BEGIN #IF CHAP <> RESCHAPTER &THEN )BEGIN (* FET *) ,CN.IMAGE[1] := DIGIT(CHAP DIV 10) ; ,CN.IMAGE[2] := BEGIN #OPENNEW(VALNEW, VNAME) ; #VALNEW^ := VAL^ ; #CLOSE(VAL) ; #PUT(VALNEW) ; #CLOSE(VALNEW, LOCK) ; #PAGE(OUTPUT) ; #ADIGIT(CHAP) ; ,CN.LEN := 2 ; ,CONVERT(CN,CHNUM) ; ,CHAPNAME := CONCAT(COPY(VAL^.COURSE,1,3), 'CH', CHNUM) ; ,DIRNAME := CONCT(15, 20) ; #P(BYESTR) ; END ; (* WINDUP *) PROCEDURE WAITCR ; BEGIN #REPEAT &AT(23, 15) ; &WRITE( 'Please press the RETURNAT(CHAPNAME, '.DIR') ; ,TEXTNAME := CONCAT(CHAPNAME, '.TEXT') ; ,CLOSE(RANFIL) ; ,ERR := NOT RANOPEN(TEXTNAME) ; ,IF ERR /T key to continue. ') ; &READSTR(INPUT, IMB) ; &USERCOM ; #UNTIL IMB.LEN = 0 ; END ; (* WAITCR *) PROCEDURE LOGIN ; (* LogHEN ����������������������������������������������������������������������������������������������������������������������������in student, read validation file *) VAR ERR : BOOLEAN ; BEGIN #PAGE(OUTPUT) ; #INIT ; #AT(10,15) ; #WRITELN('Welcome to CAL2ERROR(CONCAT('Can''t find ', TEXTNAME), TRUE) /ELSE 2BEGIN (* OK *) (*$I-*) 5CLOSE(DIRECTORY) ; 5OPENOLD(DIRECTORY, DIRNAMLS') ; #TRIES := 0 ; #REPEAT &AT(15,9) ; &WRITE('What is your name? ') ; &KBDLINE(STUNAME) ; &WITH STUNAME DO )FOR I := 1E) ; (*$I+*) 5IF IORESULT <> 0 8THEN ;ERROR(CONCAT('Can''t find', DIRNAME), TRUE) ; 5GET(DIRECTORY) ; 5RESCHAPTER := CHAP  TO LEN DO ,IF IMAGE[I] = ' ' /THEN 2IMAGE[I] := '-' ; &CONVERT(STUNAME, VNAME) ; &VNAME := CONCAT('*:', VNAME, '.VAL') ; (2END (* OK *) )END (* FET *) END ; (* FETCH *) PROCEDURE SEEKDRILL(FINDEX : INTEGER) ; (* Position at 'findex' *) BEGIN #WI*$I-*) &OPENOLD(VAL, VNAME) ; (*$I+*) &ERR := IORESULT <> 0 ; &IF ERR )THEN ,WRITELN('I can''t find that name listed in thiTH DIRECTORY^.DIRDATA[FINDEX] DO &SEEK(FBLOCK, FBYTE) ; #RELFRAME := 1 ; #WRONG := 0 ; #DRILLINDEX := FINDEX ; #EMPTY := TR 0 ?THEN @PROBE := PROBE + 1 ; /END ; (* ADJUST *) &END ; END ; (* FIND *) PROCEDURE HEADERTEXT ; BEGIN #GETLN ; #PAGE(OUs course!') ; ������������������������������������������������������������������������������������������������������������������TPUT); #NULLFRAME := COL1 <> ' ' ; #IF NOT NULLFRAME &THEN )BEGIN (* TXTOUT *) ,WITH DIRECTORY^.DIRDATA[DRILLINDEX] DO /WR&TRIES := TRIES + 1 ; #UNTIL (TRIES >= 3) OR NOT ERR ; END ; (* LOGIN *) PROCEDURE VALIDATE ; (* READ VALIDATIONS *) VAR ���  PROGRAM PLOTTER ;   VAR O : INTEGER ; (ESCAPE, C : CHAR ;  M : ^INTEGER ;   {$IPLOT.TEXT}    PROCEDURGER ) ; FORWARD ;  PROCEDURE D( I : INTEGER ) ; FORWARD ;   PROCEDURE A( I : INTEGER) ;  BEGIN  IF I > 0 THEN "BEGIN (AUE ; #GETLN ; END ; (* SEEKDRILL *) PROCEDURE POSITION(*CHAPTER, DRILL : INTEGER*) ; BEGIN #FETCH(CHAPTER) ; #FIND(DRILL) ; E HILBERT(ORDER : INTEGER) ;  CONST ( H0 = 256 ; (  VAR I, H, X, Y, X0, Y0 : INTEGER ;   PROCEDURE PLOT ;  BEGIN  #SEEKDRILL(PROBE) ; END ; (* POSITION *) �������������������������������������������������������������������������������������� LINE(X, Y) ;  END ;   PROCEDURE B( I : INTEGER ) ; FORWARD ;  PROCEDURE C( I : INTEGER ) ; FORWARD ;  PROCEDURE D( I : �INTEGER ) ; FORWARD ;   PROCEDURE A ( I : INTEGER ) ;  BEGIN (IF I > 0 THEN (BEGIN 0D(I-1) ; X := X - H ; PLOT ; 0A(I-1)� ; Y := Y - H ; PLOT ; 0A(I-1) ; X := X + H ; PLOT ; 0B(I-1) (END ;  END ;   PROCEDURE B { I : INTEGER } ;  BEGIN (IF I�����������������������������������������������������������������������������������������������������������������������O��^� > 0 THEN (BEGIN 0C(I-1) ; Y := Y + H ; PLOT ; 0B(I-1) ; X := X + H ; PLOT ; 0B(I-1) ; Y := Y - H ; PLOT ; 0A(I-1) (END ; � END ;   PROCEDURE C { I : INTEGER } ;  BEGIN (IF I > 0 THEN (BEGIN 0B(I-1) ; X := X + H ; PLOT ; 0C(I-1) ; Y := Y + H �; PLOT ; 0C(I-1) ; X := X - H ; PLOT ; 0D(I-1) (END ;  END ;   PROCEDURE D { I : INTEGER } ;  BEGIN (IF I > 0 THEN �����(BEGIN 0A(I-1) ; Y := Y - H ; PLOT ; 0D(I-1) ; X := X - H ; PLOT ; 0D(I-1) ; Y := Y + H ; PLOT ; 0C(I-1) (END ;  END ;  �  BEGIN (* HILBERT *) (STARTPLOT ; (I := 0 ; H := H0 ; X0 := H DIV 2 + 32 ; (Y0 := H DIV 2 - 8 ; (REPEAT 0I := I + 1 ; 0H� := H DIV 2 ; 0X0 := X0 + (H DIV 2) ; 0Y0 := Y0 + (H DIV 2) ; 0X := X0 ; 0Y := Y0 ; (UNTIL I = ORDER ; 0AT(X,Y) ; 0A(I) ;�  END ; { HILBERT }   PROCEDURE SIERPINSKY(ORDER : INTEGER) ;  CONST ( H0 = 256 ; (  VAR I, H, X, Y, X0, Y0 : INTEGER ; �  PROCEDURE PLOT ;  BEGIN  LINE(X, Y) ;  END ;   PROCEDURE B( I : INTEGER ) ; FORWARD ;  PROCEDURE C( I : INTE���  - H ; Y := Y - H ; PLOT ; (C(I) ; X := X - H ; Y := Y + H ; PLOT ; (D(I) ; X := X + H ; Y := Y + H ; PLOT ; ������������������ END ; { SIERPINSKY }   BEGIN { PLOTTER }  ESCAPE := CHR(27) ;  MARK(M) ;  REPEAT #RELEASE(M) ; #REPEAT (WRITE('Hilber�t or Sierpinsky? ') ; # READ(C) ; (CASE C OF ('H' : WRITE('ilbert') ; ('S' : WRITE('ierpinnsky') (END ; (WRITELN ; #U�NTIL C IN ['H', 'S', ESCAPE] ;  #IF C <> ESCAPE THEN #BEGIN { DOIT } 'WRITE('Order? ') ; 'READLN(O) ; 'PAGE(OUTPUT) ; ' �(I-1) ; X := X + H ; Y := Y - H ; PLOT ; (B(I-1) ; X := X + 2 * H ; PLOT ; (D(I-1) ; X := X + H ; Y := Y + H ; PLOT ; (A(I-1)' CASE C OF *'H' :HILBERT(O) ; *'S' : SIERPINSKY(O)  END ; # #END ; { DOIT }  UNTIL C = ESCAPE ;  END.  ����� "END ;  END ; { A }   PROCEDURE B{ I : INTEGER } ;  BEGIN !IF I > 0 THEN !BEGIN ����������������������������������������(B(I-1) ; X := X - H ; Y := Y - H ; PLOT ; (C(I-1) ; Y := Y - 2 * H ; PLOT ; (A(I-1) ; X := X + H ; Y := Y - H ; PLOT ; (B(I�-1) !END ;  END ; { B }   PROCEDURE C { I : INTEGER } ;  BEGIN { C } !IF I > 0 THEN !BEGIN (C(I-1) ; X := X - H ; Y := �Y + H ; PLOT ; (D(I-1) ; X := X - 2 * H ; PLOT ; (B(I-1) ; X := X - H ; Y := Y - H ; PLOT ; (C(I-1) !END ;  END ; { C }  � PROCEDURE D { I : INTEGER } ;  BEGIN !IF I > 0 THEN !BEGIN (D(I-1) ; X := X + H ; Y := Y + H ; PLOT ; (A(I-1) ; Y := Y + �����������������������������������������������������������������������������������������������������������������������O��^�2 * H ; PLOT ; (C(I-1) ; X := X - H ; Y := Y + H ; PLOT ; (D(I-1) !END ;  END ; { D }   BEGIN { SIERPINSKY } (STARTPLOT �; (I := 0 ; H := H0 DIV 4 ; X0 := 2 * H + 40 ; Y0 := 3 * H + 4 ; (REPEAT 0I := I + 1 ; 0X0 := X0 - H ; 0H := H DIV 2 ; 0Y0� := Y0 + H ; 0X := X0 ; Y := Y0 ; (UNTIL I = ORDER ;  (AT(X, Y) ; (A(I) ; X := X + H ; Y := Y - H ; PLOT ; (B(I) ; X := X����  $PLACE, READBLOCKS, WRITEBLOCKS : INTEGER ; $FNAME : STRING ;  BEGIN $FNAME := FILELIST[NUM] ; $WRITELN('Copying ', FNAMIST[FILES] := INFILE ; <END ; 0END ; $UNTIL (INFILE = '') OR (FILES >= MAXFILES) ; END ; { Openin }  BEGIN { Concatenate }E) ; IF NUM = 1 THEN *PLACE := 0 (ELSE *PLACE := 2 ;  (CLOSE(INP) ; (RESET(INP, FNAME) ;  (REPEAT ������������ $PAGE(OUTPUT) ; $WRITELN ; $WRITELN(' ' : 25, 'FASTCAT : Concatenate files quickly.') ; $WRITELN ; $REPEAT (OPENOUT ; (O0READBLOCKS := BLOCKREAD (INP, BUF, MAXBLOCK, PLACE) ;  0WRITEBLOCKS:= BLOCKWRITE(OUT, BUF, READBLOCKS) ; 0 0PLACE := PLACPENIN ; (FOR F := 1 TO FILES DO ,COPYF(F) ; (CLOSE(OUT, LOCK) ; $ WRITELN('Files copied to ', OUTNAME) ; $UNTIL FALSE ; E + READBLOCKS ; 0 0IF WRITEBLOCKS < READBLOCKS THEN 0BEGIN 3WRITELN('Out of room on output device!') ; 3EXIT(CONCATENATE) END. ���������������������������������������������������������������������������������������������������������������������������; 0END ; )UNTIL READBLOCKS = 0 ; )  END ; { PACK } PROCEDURE OPENOUT ; { Ask for and open output file } BEGIN $REPEAT (W�RITE('Output file:') ; (READLN(OUTNAME) ; (IF OUTNAME = '' ,THEN 0EXIT(CONCATENATE) ; (IF POS(OUTNAME, '.TEXT') = 0 ,THEN �����������������������������������������������������������������������������������������������������������������������O��^�0OUTNAME := CONCAT(OUTNAME, '.TEXT') ; {$I-} (REWRITE(OUT, OUTNAME) ; {$I+} (ERROR := IORESULT <> 0 ; (IF ERROR ,THEN 0W�  { FASTCAT : Concatenate files quickly  (George Gonzalez 9-OCT-78 ( ( FASTCAT asks for an output file and a listRITELN('Can''t open output file ',OUTNAME) ; $UNTIL NOT ERROR ; END ; { OPENOUT }    FUNCTION OPEN( INFILE : STRING ) :  of input files. (It then copies all the input files in sequence to the (output file.  +As FASTCAT is designed to bBOOLEAN ;  BEGIN &{$I-} &CLOSE(INP) ; &RESET(INP, INFILE) ; &{$I+} &OPEN := IORESULT = 0 ;  END ;  0   PROCEDURE OPe as fast as possible, no (block compression can be done between the input files.   }   PROGRAM CONCATENATE( INPUT, OUTPUENIN ; { Ask for input file list } VAR $INFILE : STRING ; BEGIN $FILES := 0 ; ����������������������������������������������T ) ;   CONST &MAXFILES = 100 ; VAR $OUTNAME : STRING ; $FILELIST : ARRAY[1..MAXFILES] OF STRING ; $INP, OUT $WRITELN('Enter list of input files, RETURN to end list.') ; $REPEAT (WRITE('Input file:') ; (READLN(INFILE) ; (IF INFILE < : FILE ; $F, FILES : INTEGER ; $ERROR : BOOLEAN ;   PROCEDURE COPYF( NUM : INTEGER ) ; { COPY FILE AND PAC> '' ,THEN 0BEGIN 4ERROR := NOT OPEN(INFILE) ; 4IF ERROR 8THEN <BEGIN @INFILE := CONCAT(INFILE, '.TEXT') ; @ERROR := NOTK } CONST (MAXBLOCKS = 40 ;   TYPE (BLOCK = PACKED ARRAY[1..512] OF CHAR ; (  VAR $BUF : ARRAY[1..MAXBLOCK] OF BLOCK ; OPEN(INFILE) ; <END ; 4IF ERROR 8THEN <WRITELN(CHR(7),'Can''t find ', INFILE) 8ELSE <BEGIN @FILES := FILES + 1 ; @FILEL��� � END ;   PROCEDURE AT(X, Y : INTEGER) ;  BEGIN (WHEREX := X ; (WHEREY := Y ; (NEWPLACE := TRUE ;  END ;   PROCEDURE �POINT(X, Y : INTEGER) ;  BEGIN 'AT(X, Y) ; 'IF (X >= XLWINDOW) AND ( X <= XHWINDOW) 'AND(Y >= YLWINDOW) AND ( Y <= YHWINDOW)� 'THEN 'CASE PEN OF 'WHITE : DRAWSCR^[Y,X] := TRUE ; 'BLACK : DRAWSCR^[Y,X] := FALSE ; 'FLIP : DRAWSCR^[Y,X] := NOT DRAWSC { (TERAK Graphics Package ( (Includes STARTPLOT, LINE, BOX, CIRCLE, ARC, AT ( DISPLAY, ERASE (  }   {$R-} R^[Y,X] 'END ; 'NEWPLACE := FALSE ;  END ; { POINT }   PROCEDURE LINE(X, Y : INTEGER) ;  VAR SX, SY, WX, WY, JUNK : INTEG CONST GRAPHIC = 3 ; ROWSIZE = 240 ; COLSIZE = 320 ;   TYPE (PENCOLOR = (NULLCOLOR, WHITE, BLACK, FLIP ) ; (SCREEN = PACKER ;   PROCEDURE WINDOW(VAR X, Y : INTEGER ; 1WHEREX, WHEREY : INTEGER) ;  VAR (SLOPE : REAL ; (DX, DY : INTEGER ;  BEGED ARRAY[1..ROWSIZE, 1..COLSIZE] OF BOOLEAN ; (BITW = (ALOW, AMID, ATOP, 2GLOW, GMID, GTOP, 2B6, GENBUF, CLICKBIT, 2B9, B1IN { WINDOW } (DX := X - WHEREX ; DY := Y - WHEREY ; (IF DX <> 0 THEN SLOPE := DY / DX ; ( (IF X < XLWINDOW THEN �����������0, BEEPBIT, 2B12, B13, B14, B15) ; & (SCRCONFIG = SET OF BITW ; (SCP = ^SCREEN ;   VAR WHEREX, WHEREY, 'XLWINDOW, XHW,BEGIN { XTL } ,IF DX <> 0 THEN /BEGIN { TRIMX } 2Y := WHEREY - ROUND((WHEREX-XLWINDOW) * SLOPE) ; 2X := XLWINDOW ; /END INDOW, YLWINDOW, YHWINDOW : INTEGER ; 'NEWPLACE : BOOLEAN ; 'PEN : PENCOLOR ; 'DISSCR, DRAWSCR : SCP ;   PROCEDURE DISPLA{ TRIMX } ,END { XTL } (ELSE (IF X > XHWINDOW THEN ,IF DX <> 0 THEN 0BEGIN { TRIMXH } 3Y := WHEREY - ROUND((WHEREX-XHWINDOY( SCPTR : SCP; HOW : SCRCONFIG ) ;  VAR X : PACKED RECORD 'CASE BOOLEAN OF /FALSE: ( INT : INTEGER ) ; /TRUE : ( SETT :W) * SLOPE) ; 3X := XHWINDOW ; 0END ; { TRIMXH } + (IF DY <> 0 THEN ,IF Y < YLWINDOW THEN 0BEGIN { YTS } 0IF DX <> 0 THEN SCRCONFIG ) 'END ;   BEGIN &IF HOW = [] THEN .HOW := [ALOW..GTOP] ; &X.SETT := HOW ; &DISSCR := SCPTR ; &UNITWRITE(GR 7X := WHEREX - ROUND((WHEREY-YLWINDOW) / SLOPE) ; 7Y := YLWINDOW ; 0END { YTS } ,ELSE ,IF Y > YHWINDOW THEN .BEGIN { YTL �APHIC, DISSCR^, X.INT) ;  END ;   PROCEDURE ERASE( SC : SCP ) ;  BEGIN (FILLCHAR(SC^, SIZEOF(SCREEN), 0) ;  END ;  ����� PROCEDURE STARTPLOT ;  BEGIN (WHEREX := 0 ; WHEREY := 0 ; PEN := WHITE ; (XLWINDOW := 1 ; (YLWINDOW := 1 ; (XHWINDOW := 3�20 ; (YHWINDOW := 240 ; (NEWPLACE := TRUE ; (NEW(DISSCR) ; (DRAWSCR := DISSCR ; (ERASE(DRAWSCR) ; (DISPLAY(DRAWSCR, []) ; ��� } .IF DX <> 0 THEN 6X := WHEREX - ROUND((WHEREY-YHWINDOW) / SLOPE) ; 6Y := YHWINDOW ; .END ; { YTL }  END ; { WINDOW }  ND ; { DRAW }  END ; { ARC }   PROCEDURE CIRCLE( RADIUS : INTEGER ) ;  BEGIN &ARC(RADIUS, 0, 360) ;  END ;   {$R+} �� BEGIN { LINE } 0SX := X ; SY := Y ; 0WINDOW(X, Y, WHEREX, WHEREY) ; 0WX := WHEREX ; WY := WHEREY ; 0WINDOW(WHEREX, WHEREY, �SX, SY) ; 0IF (X >= XLWINDOW) AND ( X <= XHWINDOW) 0AND(Y >= YLWINDOW) AND ( Y <= YHWINDOW) 2AND ((X <> WHEREX) OR (Y <> WHER�EY)) 2THEN 4BEGIN { DRAW } 6IF NEWPLACE OR (WX<>WHEREX) OR (WY<> WHEREY) 8THEN POINT(WHEREX, WHEREY) ; ����������������������6DRAWLINE(JUNK, DRAWSCR^, 20, WHEREX-1, WHEREY-1, ?X-WHEREX, Y-WHEREY, ORD(PEN)) ; 4END ; { DRAW } 0 0WHEREX := SX ; WHEREY� := SY ;  END ; { LINE }   PROCEDURE BOX( WIDTH, HEIGHT, THICK, SPACING : INTEGER ) ;  VAR I, LX, LY : INTEGER ;   BEGIN� { BOX }  'WIDTH := WIDTH - 1 ; 'HEIGHT := HEIGHT - 1 ; 'LX := WHEREX ; LY := WHEREY ; 'FOR I := 1 TO THICK DO 'BEGIN { S�QUARE } /AT(LX, LY) ; /LINE(WHEREX+WIDTH, WHEREY) ; /LINE(WHEREX, WHEREY+HEIGHT) ; /LINE(LX, WHEREY) ; /LINE(LX, LY) ; /LX�����������������������������������������������������������������������������������������������������������������������O��^� := LX + SPACING ; /LY := LY + SPACING ; /HEIGHT := HEIGHT - 2 * SPACING ; /WIDTH := WIDTH - 2 * SPACING ; 'END ; { SQUARE }�  END ; { BOX }    PROCEDURE ARC(RADIUS, START, FINISH : INTEGER) ;  CONST &W = 0.0174533 ;  VAR &CX, CY, ST, FIN, STE�P : REAL ;  BEGIN { ARC }  IF RADIUS <> 0 THEN "BEGIN { DRAW } &STEP := 2.0 / RADIUS ; &ST := START ; &ST := ST * W ; &FI�N := FINISH ; &FIN := FIN * W ; &CX := WHEREX ; &CY := WHEREY ; &AT(WHEREX + RADIUS, WHEREY) ; & &WHILE ST <= FIN DO ������&BEGIN { SEG } .LINE( ROUND(CX + RADIUS * COS(ST)), 4ROUND(CY + RADIUS * SIN(ST)) ) ; .ST := ST + STEP ; &END ; { SEG } "E���� (MOVELEFT(RANBUF[BUFPTR], IMAGE, L) ; { Copy first part of line } (BS := L + 1 ; (SEEK(RESBLK+1, 1) ; (IF RANEOF THEN GOTO 5� ; (GOTO 1 ; { For maximum speed, if not clarity! } $  3: MOVELEFT(RANBUF[BUFPTR], IMAGE[BS], P) ; { Move rest of line } $I�F ( BUFPTR+ P ) < BUFSIZE $ THEN )BUFPTR := BUFPTR + P + 1 %ELSE )BEGIN -BUFPTR := BUFSIZE ; -RANBUF[BUFPTR] := CHR(0) ; ��)END ; { Update line base } $P := P + BS - 1 ; $  2: EX := SCAN(P, = CHR(EAT), IMAGE) ; { Check for space eater character } �$ $IF EX >= P THEN GOTO 4 ; { If no eaters } , (SP := EX + 3 ; (L := ORD(IMAGE[EX+2])-34 ; (IF L > 0 THEN ,MOVERIGHT(IMAG  { RANDOM READ ROUTINES } FUNCTION RANOPEN(FNAME : STRING) : BOOLEAN ; { Attempt to open random file } {$I-} BEGIN { RANOPEN E[SP], IMAGE[SP+L], P-SP+1) { lengthen } (ELSE ,MOVELEFT(IMAGE[SP], IMAGE[SP+L], P-SP+1) ; { shorten } ( (IF L > -2 THEN FIL} $CLOSE(RANFIL) ; $RESET(RANFIL, FNAME) ; $RANOPEN := IORESULT = 0 ; $RESBLK := -1 ; $RANEOF := TRUE ; $SPCOUNT := 0 ; ENLCHAR(IMAGE[EX+1], L+2, ' ') ; { space fill } (P := P + L ; (GOTO 2 ; { For speed only!! }   4: END ; { X } $X.LEN := P ;D ; { RANOPEN } {$I+ } PROCEDURE RANREAD(B : INTEGER) ; { READ BLOCK B } BEGIN $RANEOF := BLOCKREAD(RANFIL, RANBUF, 1, B+2) <   5: END ; { GETRANLINE } {$G-}  ��������������������������������������������������������������������������������������������1 END ;  PROCEDURE SEEK( BLK, BYT : INTEGER ) ; { Position at BLK, BYT } BEGIN $IF RESBLK <> BLK THEN $RANREAD(BLK) ; $RE�����������������������������������������������������������������������������������������������������������������������O��^�SBLK := BLK ; $BUFPTR := BYT ; END ; { SEEK } {$G+} PROCEDURE GETRANLINE(VAR X : STR ) ; { READ LINE FROM RANDOM FILE } LABEL ������������������������������������������������������������������������������������������������������������������������������(1,2,3,4,5 ; CONST (CR = 13 ; EAT = 16 ; VAR (P, L, Z, EX, SP, BS : INTEGER ;  BEGIN WITH X DO BEGIN { GRL } $BS := 1 ;�  1: L := BUFSIZE - BUFPTR + 1 ; { Chars left in line } $P := SCAN(L, = CHR(CR), RANBUF[BUFPTR]) ; { Look for eol } $IF P < �L THEN GOTO 3 ; { If full line gotten } ( (IF RANBUF[BUFPTR] = CHR(0) THEN L := 0 ; { If trailing nulls } ������������������������ :=15 DOWNTO 0 DO %WRITE(B0[I]); #WRITELN; #WRITELN !END !END !END  END;   PROCEDURE DECTO;  VAR NUM:STRING[6]; �����J:=LENGTH(NUM); %ENDSTR := 1; %VALID:=TRUE; %IF LENGTH(NUM) = 6 THEN (IF NUM[1] = '1' THEN +BEGIN .B0[15] := 1; .ENDSTR :$BIT15, MINUS:BOOLEAN;  BEGIN "WITH R.HEXREC DO BEGIN "WITH R.OCTREC DO BEGIN "WITH R.BINREC DO BEGIN %WRITE('DECIMAL NUMB= 2 +END (ELSE VALID := FALSE; %WHILE (J>= ENDSTR) AND VALID DO (BEGIN +IF NUM[J] IN OCTLET THEN .E0[I]:= ORD(NUM[J])-ORD(ER = '); %READLN(NUM); %IF NUM = '' THEN EXIT(DECTO); %MINUS:=FALSE; %IF NUM[1] = '-' THEN (BEGIN +MINUS:=TRUE; +I:=2 ('0') +ELSE .VALID:=FALSE; +I:=I+1; +J:=J-1; (END; %IF NOT VALID THEN WRITELN('INVALID OCTAL NUMBER') 2ELSE WRITEO "END; END %ELSE (I:=1; %VALID:=TRUE; %R.INT:=0; %WHILE (I<=LENGTH(NUM)) AND VALID DO (BEGIN +IF NUM[I] IN DECLET THEN .BEGIN  (*BEGIN'S*) "END; "END;  END; (*OCTTO*) "  PROCEDURE BINTO;  VAR NUM:STRING[16];  BEGIN "WITH R.HEXREC DO BEGIN �������1IF R.INT >= 3277 THEN 4BEGIN 7BIT15 := TRUE; 7R.INT := R.INT - 3277 4END; 1R.INT:=(R.INT*10)+ORD(NUM[I])-ORD('0') .END +"WITH R.OCTREC DO BEGIN "WITH R.BINREC DO BEGIN %R.INT := 0; %WRITE('BINARY NUMBER = '); %READLN(NUM); %I:=LENGTH(NUM); %ELSE .VALID:=FALSE; +I:=I+1; (END; %IF MINUS THEN R.INT:=R.INT*(-1); %IF BIT15 THEN B0[15] := 1; %IF NOT VALID THEN WRITELVALID:=TRUE; %J:=0; %WHILE (I>=1) AND VALID DO (BEGIN +IF NUM[I] IN BINLET THEN .B0[J]:=ORD(NUM[I])-ORD('0') +ELSE .VAL {$D0}  PROGRAM CONVERSION;  TYPE OREC = %PACKED RECORD (E0:PACKED ARRAY[0..4] OF 0..7 %END; %  HREC = $PACKED RECON('INVALID DECIMAL NUMBER') 2ELSE WRITEO "END; (*BEGIN'S*) "END; "END;  END; (*DECTO*) %  PROCEDURE HEXTO;  VAR NUM:STRRD 'H0:PACKED ARRAY[0..3] OF 0..15 $END; $ $BREC = $PACKED RECORD 'B0:PACKED ARRAY[0..15] OF 0..1 $END; $ $LETSET = SETING[4];  BEGIN "WITH R.HEXREC DO BEGIN "WITH R.OCTREC DO BEGIN "WITH R.BINREC DO BEGIN %R.INT := 0; %WRITE('HEXADECIMAL IN OF '0'..'F'; %  VAR $R: RECORD )CASE INTEGER OF ,1:(INT:INTEGER); $ 2:(OCTREC:OREC); ,3:(HEXREC:HREC); $ TEGER ='); %READLN (NUM); %I:=0; %VALID:=TRUE; %J:=LENGTH(NUM); %WHILE (J>=1) AND VALID DO (BEGIN ����������������������� 4:(BINREC:BREC) )END; $CH: CHAR; $OCTLET,BINLET,DECLET,HEXLET: LETSET; $K,I,J: INTEGER; $VALID: BOOLEAN;   PROCEDURE WR+IF NUM[J] IN HEXLET THEN .H0[I]:=ORD(NUM[J])-ORD('A')+10 +ELSE .IF NUM[J] IN DECLET THEN 1H0[I]:=ORD(NUM[J])-ORD('0') .EITEO;  BEGIN "WITH R.HEXREC DO BEGIN "WITH R.OCTREC DO BEGIN "WITH R.BINREC DO BEGIN #WRITELN; #WRITELN('DECIMAL = ',RLSE 1VALID:=FALSE; +J:=J-1; +I:=I+1; (END; %IF NOT VALID THEN WRITELN('INVALID HEXADECIMAL NUMBER') 2ELSE WRITEO; "END; .INT); #WRITE('HEXADECIMAL = '); #FOR I:=3 DOWNTO 0 DO &BEGIN )IF H0[I] < 10 THEN WRITE(H0[I]) )ELSE WRITE(CHR(H0[I]-10+ORD(*BEGIN'S*) "END; "END;  END; (*HEXTO*)   PROCEDURE OCTTO;  VAR NUM:STRING[6]; $ENDSTR: INTEGER;  BEGIN "WITH R.HEXREC('A'))); &END; #WRITELN; #WRITELN('OCTAL = ', B0[15],E0[4],E0[3],E0[2],E0[1],E0[0]); #WRITE('BINARY = '); #FOR I DO BEGIN "WITH R.OCTREC DO BEGIN "WITH R.BINREC DO BEGIN %R.INT := 0; %WRITE('OCTAL INTEGER = '); %READLN(NUM); %I:=0; %��� ELN(' BINARY : 16 BITS'); "WRITELN; "WRITELN('HEXADECIMAL,BINARY AND OCTAL INTEGERS ARE IN 16 BIT TWO''S'); "WRITELN('�COMPLEMENT REPRESENTATION. IF AN ENTERED DECIMAL INTEGER'); ��������������������������������������������������������������������"WRITELN('IS OUTSIDE THE RANGE 32767<= X <=-32768 THEN THE HEX, OCTAL'); "WRITELN('AND BINARY NUMBERS WILL HAVE AN "UNDERSTOO�D" SIGN BIT. WHEN '); "WRITELN('HEX, OCTAL OR BINARY INTEGER IS ENTERED THE I6TH BIT (IF THERE '); "WRITELN('IS ONE) WILL BE �TAKEN AS A SIGN BIT'); "WRITELN; "WRITELN('FOR USE IN THIS PROGRAM TYPE:'); "WRITELN(' ''H'' FOR HEXADECIMAL'); "WRITELN(' � ''D'' FOR DECIMAL'); "WRITELN(' ''B'' FOR BINARY'); "WRITELN(' ''O'' FOR OCTAL'); "WRITELN(' ''C'' FOR GETTING THESE COMM{ REBOOT : Change bootstrap to load different interpreter  (REBOOT toggles the bootstrap to alternately load the systemENTS'); "WRITELN(' ''Q'' FOR QUITTING THE PROGRAM');  END; (*COMMENTS*) $  BEGIN (*MAIN PROGRAM*) "HEXLET:=['A'..'F']; "D (interpreter from files: ( 0SYSTEM.INTERS Small interpreter 0SYSTEM.INTERB Big interpreter 0  It then boots tECLET:=['0'..'9']; "OCTLET:=['0'..'7']; "BINLET:=['0'..'1']; "REPEAT %WRITE('I WOULD LIKE TO CONVERT INTEGERS IN '); %READ he system to re-load the interpreter.  }  {$G+}  PROGRAM REBOOT ;  LABEL 5 ;  CONST (SYSVOL = 4 ; (BOOTBLOCK = 0 ;  (CH); %WRITELN; %CASE CH OF ''C': COMMENTS; ''H': HEXTO; ''O': OCTTO; ''B': BINTO; ''D': DECTO %END; "UNTIL CH = 'Q';  BLOCK = 512 ;   VAR (BUF : PACKED ARRAY[1..BLOCK] OF CHAR ; (OLD : CHAR ; (K, FN, EXT : INTEGER ;  V : RECORDID:=FALSE; +I:=I-1; +J:=J+1; (END; %IF NOT VALID THEN WRITELN('INVALID BINARY NUMBER') 2ELSE WRITEO "END; (*BEGIN'S*) "E END.  ����������������������������������������������������������������������������������������������������������������������ND; "END;  END; (*BINTO*)   PROCEDURE COMMENTS;  BEGIN "WRITELN; "WRITELN('THIS PROGRAM CONVERTS BETWEEN DECIMAL, OCTAL�����������������������������������������������������������������������������������������������������������������������O��^�, AND '); "WRITELN('HEXADECIMAL INTEGERS.'); "WRITELN('THE LARGEST INTEGERS THIS PROGRAM WILL USE IS:'); "WRITELN(' HEXADEC�IMAL: 7FFF FFFF'); "WRITELN(' DECIMAL : 65535 -65535 '); "WRITELN(' OCTAL : 077777 177777'); "WRIT���� ABEL 1, 2, 3 ;  VAR (BASE, I, J, K : INTEGER ;  BEGIN (BASE := 0 ; (PLACE := 0 ; ( (2 : BASE := BASE + 1 ; (FOR I := BAS�E TO (BLOCK - LENGTH(S)) DO *IF BUF[I] = S[1] THEN GOTO 1 ; { FOUND ONE } *GOTO 3 ; { NOGO } * %1: BASE := I ; %FOR J := 1 �TO LENGTH(S) DO +IF BUF[BASE+J-1] <> S[J] THEN GOTO 2 ; + +PLACE := BASE ;  3 :  END ;   BEGIN ��������������������������(UNITREAD(SYSVOL, BUF, BLOCK, BOOTBLOCK) ; ( (FN := PLACE('SYSTEM.INTER') ; ( (IF FN = 0 THEN (BEGIN ,WRITELN('Can''t fin�d interpreter!!') ; ,GOTO 5 ; (END (ELSE (BEGIN (EXT := FN + 12 ;  {BUF[EXT] := 'S' ;} (OLD := BUF[EXT] ; (IF OL�D = 'B' THEN 0BUF[EXT] := 'S' 0ELSE 0IF OLD = 'S' THEN 0BUF[EXT] := 'B' 0ELSE 0BEGIN 4WRITELN('Don''t recognize extension� of:', BUF[EXT]) ; 4GOTO 5 ; 0END ; ( (UNITWRITE(SYSVOL, BUF, BLOCK, BOOTBLOCK) ; (WRITELN(OLD, ' changed to ', BUF[EXT]) ; PROGRAM COMPARE(FILEA, FILEB, OUTPUT, MODS); { COPYRIGHT (C) 1977 } { J. F. MINER, SSRFC, U OF MINN. } { A (FOR K := 1 TO 1000 DO ; ( ({ Now boot the system } (V.A := 4 ; (V.P^ := -2560 ; { 173000B } (V.A := -1 ; (V.P^ := 1 ({LL RIGHTS RESERVED. } { DEVELOPMENTAL, BUYER BEWARE... } { J. P. STRAIT, UCC, U OF MN, 77/07/10. } { GENERATE  Never gets this far } (END ; (  5:  END.  �������������������������������������������������������������������������������UPDATE DIRECTIVES. } { J. P. STRAIT, UCC, U OF MN, 77/09/12. } { 1. GENERATE FLAG FORM OUTPUT. } { 2. S�ELECT ONE OF THREE OUTPUT FORMS } { WITH AN OPTION. } { 3. CONTROL STATEMENT PROCESSING. } "{� G. GONZALEZ, UCC, U of MN. 15-AUG-78 } "{ Adapt to UCSD Pascal } " CONST VERSION = '2.0'; COMPILEDATE �����������������������������������������������������������������������������������������������������������������������O��^�= '15-AUG-78'; MAXLENGTH = 150; IDENTLENGTH = 8; NOIDENT = ' '; { SHOULD HAVE IDENTLENGTH BLANKS } TYPE  CASE BOOLEAN OF 0TRUE : ( A : INTEGER ) ; 0FALSE: ( P : ^INTEGER) ; -END ;   FUNCTION PLACE( S : STRING ) : INTEGER ;  L�� ��  P = NIL THEN WRITELN(' *** EOF ***'); %WRITELN $END; #FLAGS : $BEGIN %IF FLAG = 'D' THEN WRITELN; %WHILE (P <> NIL) AGTH; %C3 : 1..IDENTLENGTH; %N : 0..30000; #BEGIN { READLINE } $IF NOT X.ENDFILE THEN %BEGIN &C := 0; &WHILE NOT EOLN(FILEND (P <> Q) DO &BEGIN 'IF FLAG = 'D' THEN WRITE(' D ') 'ELSE WRITE(' ',FLAG,L:6,'. '); 'WRITELINE(OUTPUT) X) AND (C < LINELENGTH) DO 'BEGIN C := C + 1; TEMPLINE.IMAGE[C] := FILEX^; GET(FILEX) END; ���������������������������������� ALFA = PACKED ARRAY[1..10] OF CHAR ;  LINEIDENTIFICATION = #PACKED RECORD $IDENT : PACKED ARRAY[1..IDENTLENGTH] OF CHAR; &END; %IF FLAG = 'D' THEN WRITELN $END; #MODIFICATIONS: $WHILE (P <> NIL) AND (P <> Q) DO %WRITELINE(MODS) #END END; $NUMBER : 0..30000 $END; LINEPOINTER = ^LINE; LINE = #PACKED RECORD $NEXTLINE : LINEPOINTER; $LENGTH : 0..MAXLENGTH; �{ WRITETEXT } PROCEDURE COMPAREFILES; FUNCTION ENDSTREAM(VAR X : STREAM) : BOOLEAN; BEGIN { ENDSTREAM } #ENDSTREAM := $IMAGE : PACKED ARRAY [1..MAXLENGTH] OF CHAR; $LINEID : LINEIDENTIFICATION #END; STREAM = #RECORD $CURSOR, CURSORPREVIOU(X.CURSOR = NIL) AND X.ENDFILE END; { ENDSTREAM } PROCEDURE MARK(VAR X : STREAM); #{ CAUSES BEGINNING OF STREAM TO BE PS, HEAD, TAIL : LINEPOINTER; $CURSORLINENO, HEADLINENO, TAILLINENO : INTEGER; $LINEIDPREVIOUS : LINEIDENTIFICATION; $ENDFILE OSITIONED BEFORE } #{ CURRENT STREAM CURSOR. BUFFERS GET RECLAIMED, LINE } #{ COUNTERS RESET, ETC. } #PROCEDURE COLLECT(FWA: BOOLEAN #END; VAR MODS : TEXT; LINELENGTH : 0..MAXLENGTH; OPTION : (DIFFERENCES, MODIFICATIONS, FLAGS); MINLINESF, LWAPLUS1 : LINEPOINTER); $VAR P : LINEPOINTER; #BEGIN { COLLECT } $WHILE FWA <> LWAPLUS1 DO WITH FWA^ DO %BEGIN ����������ORMATCH : INTEGER; FILEA, FILEB : TEXT; A, B : STREAM; MATCH : BOOLEAN; ENDFILE : BOOLEAN; TEMPLINE : #RECORD $LEN&X.LINEIDPREVIOUS := LINEID; &P := NEXTLINE; &NEXTLINE := FREELINES; FREELINES := FWA; &FWA := P %END #END; { COLLECT } GTH : INTEGER; $IMAGE : ARRAY [0..MAXLENGTH] OF CHAR #END; FREELINES : LINEPOINTER; SAME : BOOLEAN; PROCEDURE WRITET BEGIN { MARK } #IF X.HEAD <> NIL THEN $BEGIN %COLLECT(X.HEAD, X.CURSOR); %X.HEAD := X.CURSOR; X.CURSORPREVIOUS := NIL; EXT(VAR X : STREAM; FLAG : CHAR); VAR #P, Q : LINEPOINTER; #L : INTEGER; PROCEDURE WRITELINE(VAR F : TEXT); BEGIN { WR%X.HEADLINENO := X.CURSORLINENO; %IF X.CURSOR = NIL THEN &BEGIN X.TAIL := NIL; X.TAILLINENO := X.CURSORLINENO END $END ITELINE } #WITH P^ DO $BEGIN %IF LENGTH = 0 THEN WRITELN(F) %ELSE WRITELN(F,IMAGE:LENGTH); %P := NEXTLINE $END; #L := L +END; { MARK } PROCEDURE MOVECURSOR(VAR X : STREAM; VAR FILEX : TEXT); #{ FILEX IS THE INPUT FILE ASSOCIATED WITH STREAM  1 END; { WRITELINE } BEGIN { WRITETEXT } P := X.HEAD; Q := X.CURSOR; L := X.HEADLINENO; CASE OPTION OF ��������X. THE } #{ CURSOR FOR X IS MOVED FORWARD ONE LINE, READING FROM X } #{ IF NECESSARY, AND INCREMENTING THE LINE COUNT. ENDFI#DIFFERENCES : $BEGIN %WRITELN; %WHILE (P <> NIL) AND (P <> Q) DO &BEGIN 'WRITE(L:9,'. '); 'WRITELINE(OUTPUT) &END; %IFLE } #{ IS SET IF EOF ENCOUNTERED ON EITHER STREAM. } #PROCEDURE READLINE; $VAR %NEWLINE : LINEPOINTER; %C, C2 : 0..MAXLEN�!�� #IF X.CURSOR <> NIL THEN $BEGIN %IF X.CURSOR = X.TAIL THEN READLINE; %X.CURSORPREVIOUS := X.CURSOR; %X.CURSOR := X.CURSOR^. } #{ NOT ENDFILE AND MATCH } #MARK(A); MARK(B); #REPEAT { COMPARENEXTLINES } $MOVECURSOR(A, FILEA); MOVECURSOR(B,FILEB); NEXTLINE; %IF X.CURSOR = NIL THEN ENDFILE := TRUE; %X.CURSORLINENO := X.CURSORLINENO + 1 $END #ELSE $IF NOT X.ENDFILE THEN $IF OPTION = FLAGS THEN WRITETEXT(B, ' '); $MARK(A); MARK(B); $COMPARELINES(MATCH) #UNTIL ENDFILE OR NOT MATCH; END; { FI{ BEGINNING OF STREAM } %BEGIN &READLINE; X.CURSOR := X.HEAD; &X.CURSORLINENO := X.HEADLINENO; &X.CURSORPREVIOUS := NIL; &XNDMISMATCH } PROCEDURE FINDMATCH; #VAR $ADVANCEB : BOOLEAN; { TOGGLE ONE-LINE LOOKAHEAD BETWEEN STREAMS } �������������.LINEIDPREVIOUS.IDENT := NOIDENT; &X.LINEIDPREVIOUS.NUMBER := 1 %END $ELSE { END OF STREAM } %ENDFILE := TRUE; END; { MO#PROCEDURE SEARCH(VAR X : STREAM; { STREAM TO SEARCH } 4VAR FILEX : TEXT; 4VAR Y : STREAM; { STREAM TO LOOKAHEAD } 4VAR FILEVECURSOR } PROCEDURE BACKTRACK(VAR X : STREAM; VAR CURSORLIMIT : LINEPOINTER); #{ CAUSES THE CURRENT POSITION OF STREAM XY : TEXT); ${ LOOK AHEAD ONE LINE ON STREAM Y, AND SEARCH FOR THAT LINE } ${ BACKTRACKING ON STREAM X. } $VAR %CURSORLIMIT&WHILE TEMPLINE.IMAGE[C] = ' ' DO C := C - 1; &IF C < TEMPLINE.LENGTH THEN 'FOR C2 := C+1 TO TEMPLINE.LENGTH DO TEMPLINE.IMAG TO BECOME THAT } #{ OF THE LAST MARK OPERATION. I.E., THE CURRENT LINE } #{ WHEN THE STREAM WAS MARKED LAST BECOMES THE NEE[C2] := ' '; &TEMPLINE.LENGTH := C; &NEWLINE := FREELINES; &IF NEWLINE = NIL THEN NEW(NEWLINE) &ELSE FREELINES := FREELINEW CURRENT. } #{ THE VALUE OF THE CURSOR BEFORE BACKTRACKING IS RETURNED } #{ IN CURSORLIMIT. } BEGIN { BACKTRACK } #CURSORS^.NEXTLINE; &WITH NEWLINE^, LINEID DO 'BEGIN (FOR C2 := 1 TO MAXLENGTH DO ( IMAGE[C2] := TEMPLINE.IMAGE[C2] ; (LENGTH := CLIMIT := X.CURSOR; #X.CURSOR := X.HEAD; X.CURSORPREVIOUS := NIL; #X.CURSORLINENO := X.HEADLINENO; ���������������������������; (WHILE (FILEX^ = ' ') AND NOT EOLN(FILEX) DO GET(FILEX); (FOR C3 := 1 TO IDENTLENGTH DO )BEGIN *IDENT[C3] := FILEX^; *IF #ENDFILE := ENDSTREAM(A) OR ENDSTREAM(B) END; { BACKTRACK } PROCEDURE COMPARELINES(VAR MATCH : BOOLEAN); #{ COMPARE THFILEX^ <> ' ' THEN GET(FILEX) )END; (WHILE (FILEX^ = ' ') AND NOT EOLN(FILEX) DO GET(FILEX); (N := 0; (IF FILEX^ IN ['0'..'9E CURRENT LINES OF STREAMS A AND B, RETURNING } #{ MATCH TO SIGNAL THEIR (NON-) EQUIVALENCE. EOF ON BOTH STREAMS } #{ IS CONS'] THEN READ(FILEX, N); (NUMBER := N; (READLN(FILEX); (NEXTLINE := NIL 'END; &IF X.TAIL = NIL THEN 'BEGIN X.HEAD := NEWLIIDERED A MATCH, BUT EOF ON ONLY ONE STREAM IS A MISMATCH } BEGIN { COMPARELINES } #IF (A.CURSOR = NIL) OR (B.CURSOR = NIL) TNE; (X.TAILLINENO := 1; X.HEADLINENO := 1 'END &ELSE 'BEGIN X.TAIL^.NEXTLINE := NEWLINE; (X.TAILLINENO := X.TAILLINENO + 1HEN $MATCH := ENDSTREAM(A) AND ENDSTREAM(B) #ELSE $BEGIN %MATCH := (A.CURSOR^.LENGTH = B.CURSOR^.LENGTH); %IF MATCH THEN & 'END; &X.TAIL := NEWLINE; &X.ENDFILE := EOF(FILEX); %END #END; { READLINE } BEGIN { MOVECURSOR } ��������������������MATCH := (A.CURSOR^.IMAGE = B.CURSOR^.IMAGE) $END END; { COMPARELINES } PROCEDURE FINDMISMATCH; BEGIN { FINDMISMATCH�"�� SOR(Y, FILEY); 'COMPARELINES(MATCH); N := N - 1 &END; %X.CURSOR := SAVEXCUR; Y.CURSOR := SAVEYCUR; ������������������������ Mismatch:'); WRITELN; 'WRITE(' FILEA, '); WRITELINENO(A); WRITELN(':'); 'WRITETEXT(A, ' '); 'WRITE(' FILEB, ');%X.CURSORLINENO := SAVEXLINE; Y.CURSORLINENO := SAVEYLINE; %X.CURSORPREVIOUS := SAVEXPREV; Y.CURSORPREVIOUS := SAVEYPREV $E WRITELINENO(B); WRITELN(':'); 'WRITETEXT(B, ' ') &END $END; { PRINTDIFFERENCES } $PROCEDURE PRINTMODS; %PROCEDURE WND; { CHECKFULLMATCH } #BEGIN { SEARCH } $MOVECURSOR(Y, FILEY); BACKTRACK(X, CURSORLIMIT); $CHECKFULLMATCH; $WHILE (X.CURITELINEID(LINEID : LINEIDENTIFICATION); &VAR 'C : 0..IDENTLENGTH; %BEGIN { WRITELINEID } &IF LINEID.IDENT[IDENTLENGTH] = ' RSOR <> CURSORLIMIT) AND NOT MATCH DO %BEGIN &MOVECURSOR(X, FILEX); &CHECKFULLMATCH %END #END; { SEARCH } #PROCEDURE PR' THEN 'BEGIN (C := 1; (WHILE LINEID.IDENT[C] <> ' ' DO )BEGIN WRITE(MODS,LINEID.IDENT[C]); C := C + 1 END 'END ��������INTMISMATCH; $PROCEDURE PRINTDIFFERENCES; %VAR &EMPTYA, EMPTYB : BOOLEAN; %PROCEDURE WRITELINENO(VAR X : STREAM); &VAR &ELSE WRITE(MODS,LINEID.IDENT); &WRITE(MODS,'.', LINEID.NUMBER:1) %END { WRITELINEID }; $BEGIN { PRINTMODS } %IF A.HEAD 'F, L : INTEGER; %BEGIN { WRITELINENO } &F := X.HEADLINENO; L := X.CURSORLINENO - 1; &WRITE('LINE'); &IF F = L THEN WRIT= A.CURSOR THEN &BEGIN 'WRITE(MODS,'*INSERT,'); 'WRITELINEID(A.LINEIDPREVIOUS); 'WRITELN(MODS) &END %ELSE &BEGIN 'WRE(' ', F:1) &ELSE WRITE('S ', F:1, ' TO ', L:1); &IF X.CURSOR = NIL THEN WRITE(' (BEFORE EOF)'); %END; { WRITELINENO } %PITE(MODS,'*DELETE,'); 'WRITELINEID(A.HEAD^.LINEID); 'IF A.CURSORPREVIOUS <> NIL THEN (IF (A.CURSORPREVIOUS^.LINEID.IDENT <>ROCEDURE PRINTEXTRATEXT(VAR X : STREAM; XNAME : CHAR; >VAR Y : STREAM; YNAME : CHAR); %BEGIN { PRINTEXTRATEXT } &WRITE('  A.HEAD^.LINEID.IDENT) OR +(A.CURSORPREVIOUS^.LINEID.NUMBER <> A.HEAD^.LINEID.NUMBER) (THEN )BEGIN *WRITE(MODS,','); *WRITE : LINEPOINTER; $PROCEDURE CHECKFULLMATCH; %{ FROM THE CURRENT POSITIONS IN X AND Y, WHICH MATCH, } %{ MAKE SURE THAT THE NExtra text on file', XNAME, ', '); &WRITELINENO(X); WRITELN; &IF Y.HEAD = NIL THEN ������������������������������������������EXT MINLINESFORMATCH-1 LINES ALSO } %{ MATCH, OR ELSE SET MATCH := FALSE. } %VAR &N : INTEGER; &SAVEXCUR, SAVEYCUR, SAVEXPR'WRITELN(' before eof on file', YNAME) &ELSE 'WRITELN(' between lines ', Y.HEADLINENO-1:1, ' and ', /Y.HEADLINENO:1,EV, SAVEYPREV : LINEPOINTER; &SAVEXLINE, SAVEYLINE : INTEGER; $BEGIN { CHECKFULLMATCH } %SAVEXCUR := X.CURSOR; SAVEYCUR := Y ' of file', YNAME); &WRITETEXT(X, ' ') %END; { PRINTEXTRATEXT } $BEGIN { PRINTDIFFERENCES } %WRITELN('-----------------.CURSOR; %SAVEXLINE := X.CURSORLINENO; SAVEYLINE := Y.CURSORLINENO; %SAVEXPREV := X.CURSORPREVIOUS; SAVEYPREV := Y.CURSORPRE---------------------------------------------'); %EMPTYA := (A.HEAD = A.CURSOR); %EMPTYB := (B.HEAD = B.CURSOR); %IF EMPTYA OVIOUS; %COMPARELINES(MATCH); %N := MINLINESFORMATCH - 1; %WHILE MATCH AND (N <> 0) DO &BEGIN MOVECURSOR(X, FILEX); MOVECURR EMPTYB THEN &IF EMPTYA THEN PRINTEXTRATEXT(B, 'B', A, 'A') &ELSE PRINTEXTRATEXT(A, 'A', B, 'B') %ELSE &BEGIN 'WRITELN(' �#�� HEN WRITETEXT(B, 'A') $END; { PRINTFLAGS } #BEGIN { PRINTMISMATCH } $CASE OPTION OF %DIFFERENCES : PRINTDIFFERENCES; % DIFFERENCES; LINELENGTH := 72; MINLINESFORMATCH := 6; "CS :=  'COMPARE,F1,F2. FLAGS : PRINTFLAGS; %MODIFICATIONS : PRINTMODS %END #END; { PRINTMISMATCH } BEGIN { FINDMATCH } ���������������� ' ; "I := 1; REPEAT I := I + 1 UNTIL NOT (CS[I] IN ['A'..'Z','0'..'9',' ']); WHILE NOT (CS[I] IN [')'#{ NOT MATCH } #ADVANCEB := TRUE; #REPEAT $IF NOT ENDFILE THEN ADVANCEB := NOT ADVANCEB $ELSE ADVANCEB := ENDSTREAM(A); $I,'.','/']) DO I := I + 1; IF CS[I] = '/' THEN #BEGIN $I := I + 1; $C := CS[I]; $WHILE NOT (C IN [')','.']) DO %IF C IN ['F ADVANCEB THEN SEARCH(A, FILEA, B, FILEB) &ELSE SEARCH(B, FILEB, A, FILEA) #UNTIL MATCH; #PRINTMISMATCH; END; { FINDMATCHD','F','M','W','C',','] THEN &BEGIN 'I := I + 1; 'CASE C OF ('D' : OPTION := DIFFERENCES; ('F' : OPTION := FLAGS; ('M' : O } BEGIN { COMPAREFILES } ENDFILE := FALSE; MATCH := TRUE; { I.E., BOI MATCHES BOI } REPEAT #IF MATCH THEN FINDMISMAPTION := MODIFICATIONS; ('W' : LINELENGTH := NUMBER(10,MAXLENGTH); ('C' : MINLINESFORMATCH := NUMBER(1,100); (',' : (END; ��TCH ELSE BEGIN SAME := FALSE; FINDMATCH END UNTIL ENDFILE AND MATCH; MARK(A); MARK(B); { MARK END OF FILES, THEREBY DISPOS&C := CS[I] %END $ELSE ERROR #END; RESET(FILEA (, 'A.TEXT' (); ( RESET(FILEB *, 'B.TEXT' *); INITSTREAM(A, FILEAING BUFFERS } END; { COMPAREFILES } PROCEDURE INITSTREAM(VAR X : STREAM; VAR FILEX : TEXT); BEGIN { INITSTREAM } X.CURSO); INITSTREAM(B, FILEB); FREELINES := NIL; TEMPLINE.LENGTH := MAXLENGTH; TEMPLINE.IMAGE[0] := 'X'; { SENTINEL } WRITELN(RLINENO := 0; X.HEADLINENO := 0; X.TAILLINENO := 0; X.CURSOR := NIL; X.HEAD := NIL; X.TAIL := NIL; X.ENDFILE := EOF(FILE'Compare version ',VERSION,' ':29,'(',COMPILEDATE,')'); WRITELN; WRITE ('Output option = '); CASE OPTION OF #DIFFERX); END; { INITSTREAM } PROCEDURE INITIALIZE; TYPE CH80 = PACKED ARRAY[1..80] OF CHAR; VAR TODAY, NOW : ALFA; CS : ENCES : WRITE('Differences.'); #FLAGS : WRITE('Flags.'); #MODIFICATIONS : WRITE('Modifications.') #END; WRITELN; CH80; I : INTEGER; C : CHAR;  PROCEDURE ERROR; "BEGIN { ERROR } &WRITELN(' COMPARE CONTROL STATEMENT ERROR.'); ������� WRITELN('Input line width = ',LINELENGTH:1,' characters.'); WRITELN('Match criterion = ', MINLINESFORMATCH:1, ' lines.'); " EXIT(COMPARE) "END; { ERROR } FUNCTION NUMBER(MIN, MAX : INTEGER) : INTEGER; VAR #N : INTEGER; BEGIN { NUMBER } WRITELN; WRITELN END; { INITIALIZE } BEGIN { COMPARE } INITIALIZE; IF EOF(FILEA) THEN BEGIN WRITELN('FILEA is empty.'LINEID(A.CURSORPREVIOUS^.LINEID) )END; 'WRITELN(MODS) &END; %IF B.HEAD <> B.CURSOR THEN WRITETEXT(B, ' ') $END; { PRINTM #N := 0; #IF CS[I] IN ['0'..'9'] THEN $REPEAT N := N * 10 + ORD(CS[I]) - ORD('0'); %I := I + 1 $UNTIL NOT (CS[I] IN ['0'..ODS } $PROCEDURE PRINTFLAGS; $BEGIN { PRINTFLBGS } %IF A.HEAD <> A.CURSOR THEN WRITETEXT(A, 'D'); %IF B.HEAD <> B.CURSOR T'9']) #ELSE ERROR; #IF (N < MIN) OR (N > MAX) THEN ERROR; #NUMBER := N END; { NUMBER } BEGIN { INITIALIZE } OPTION :=�$�� US, XBOUND, YBOUND: REAL; #DEPTH, N: INTEGER; #OUTC: CHAR; #OUT: BOOLEAN; {$I PLOT.TEXT } # FUNCTION COT(ARG: REAL): REAL; FOR THE LAST ONE, MOVE THE LAST 1/3 OF THE WAY } /DIR := (DIR + HIGH1) MOD NDIR; /WEND(XK, YK, X1, Y1); ,END; ��������������); #IF EOF(FILEB) THEN WRITELN('FILEB is empty.') END ELSE IF EOF(FILEB) THEN WRITELN('FILEB is empty.') ELSE #BEGIN S# #BEGIN &COT := COS(ARG) / SIN(ARG); #END {COT}; PROCEDURE PLOT(X, Y: REAL; MODE: PLTM); # #VAR &IX, IY: INTEGER; & AME := TRUE; $COMPAREFILES; $IF SAME THEN WRITELN('No differences.') #END END. { COMPARE } ��������������������������������#BEGIN &IX := ROUND(X * 120.0) + 160; &IY := ROUND(Y * 120.0) + 120; &IF MODE IN [- 3, 2, 3] THEN )CASE MODE OF ,- 3:; ,3:�����������������������������������������������������������������������������������������������������������������������O��^� /AT(IX, IY); ,2: /LINE(IX, IY); )END; #END {PLOT}; PROCEDURE FLAKE(SIZE, XINIT, YINIT: REAL; DEPTH, N: INTEGER; OUT: BOO�LEAN); # #VAR &I, NDIR, TWON: INTEGER; &NODD: BOOLEAN; &X, Y: ARRAY [0.. MAXDIR] OF REAL; &SIDE: ARRAY [1.. MAXDEPTH] OF R�EAL; &DIVISOR, S0, X0, Y0, X1, Y1, XK, YK, ANGLE: REAL; &DIR, LOWTURN, HIGH1, HIGH2, LEVEL: INTEGER; & # ��������������������#FUNCTION SUB(K: INTEGER): INTEGER; & &VAR )DIVS: INTEGER; ) &BEGIN )IF NODD )THEN ,DIVS := 1 )ELSE ,DIVS := 2; )IF �K < 0 )THEN ,SUB := TWON + K DIV DIVS )ELSE ,SUB := K DIV DIVS; &END {SUB}; # # #PROCEDURE WEND(X0, Y0, X1, Y1: REAL); �& &VAR )XK, YK, SK: REAL; )I: INTEGER; ) &BEGIN )LEVEL := LEVEL + 1; )IF LEVEL > DEPTH )THEN ,PLOT(X1, Y1, 2) )ELSE ,�BEGIN { MOVE 1/3 OF THE WAY } /SK := SIDE[LEVEL]; /XK := X0 + SK * X[DIR]; /YK := Y0 + SK * Y[DIR]; /WEND(X0, Y0, XK, YK); {� THEN ESTABLISH CORNER OF NEXT LEVEL N-GON AND TRAVEL FROM VERTEX TO VERTEX } /X0 := XK; /Y0 := YK; /DIR := (DIR + HIGH1) MO{[A=12, S=4, Q=1]}  { (Snowflakes ( (Adapted from an ALGOL-W program in Byte magazine (George Gonzalez  }  PROGRAM FLAKYD NDIR; /XK := XK + SK * X[DIR]; /YK := YK + SK * Y[DIR]; /WEND(X0, Y0, XK, YK); /FOR I := 3 TO N DO 2BEGIN 5X0 := XK; 5Y(input, output); CONST #MAXDIR = 50; #MAXDEPTH = 50; #PI = 3.1415926; # TYPE #PLTM = - 3..3; # VAR #PLOTSIZE, SIZE, RADI0 := YK; 5DIR := (DIR + HIGH2) MOD NDIR; 5XK := XK + SK * X[DIR]; 5YK := YK + SK * Y[DIR]; 5WEND(X0, Y0, XK, YK); 2END; { �%��  := X0 + S0 * X[DIR]; )YK := Y0 + S0 * Y[DIR]; )WEND(X0, Y0, XK, YK); )FOR I := 2 TO N - 1 DO ,BEGIN /X0 := XK; /Y0 := YK;� /DIR := (DIR + LOWTURN) MOD NDIR; /XK := X0 + S0 * X[DIR]; /YK := Y0 + S0 * Y[DIR]; /WEND(X0, Y0, XK, YK); ,END; { USE TH�E SAVED COORDINATES OF THE STARTING POINT FOR THE LAST WEND } )DIR := (DIR + LOWTURN) MOD NDIR; )WEND(XK, YK, X1, Y1); &END;�����������������������������������������������������������������������������������������������������������������������O��^� #END {FLAKE}; { FLAKE } BEGIN { MAIN PROGRAM } #XBOUND := 0.0; #YBOUND := 0.0; #STARTPLOT; {READ(PLOTSIZE) ; } #PLO�)LEVEL := LEVEL - 1; &END {WEND}; # # #BEGIN { FLAKE } &NODD := ODD(N); &TWON := 2 * N; &IF NODD &THEN )NDIR := TWON TSIZE := 10.0; #PLOT(0.0, - 10.0, - 3); #WRITE('Enter Depth, Number of sides, In or Out'); #READ(DEPTH, N, OUTC); #RADIUS :=&ELSE )NDIR := N; &BEGIN { CALCULATE THE UNIT VECTORS IN THE POSSIBLE DIRECTIONS. } )FOR I := 0 TO NDIR - 1 DO ,BEGIN /ANGL 1.0; #OUT := OUTC <> 'I'; #WHILE RADIUS > 0.0 DO &BEGIN )SIZE := 2.0 * RADIUS; )IF YBOUND + SIZE + 2.0 > PLOTSIZE THEN ,BE := (2 * I / NDIR) * PI; /X[I] := COS(ANGLE); /Y[I] := SIN(ANGLE); ,END; { CALCULATE THE POLYGON SIDELENGTHS AT EACH LEVEL EGIN /PLOT(XBOUND + 2.0, - PLOTSIZE, - 3); /XBOUND := 0.0; /YBOUND := 0.0; ,END; )IF XBOUND < RADIUS THEN ,BEGIN ��������� } )IF OUT )THEN ,BEGIN /IF NODD /THEN 2IF N = 3 2THEN 5DIVISOR := 1.0 2ELSE 5DIVISOR := 0.5 * COS(PI / N) * SQRT(10.0/PLOT(RADIUS - XBOUND, 0.0, - 3); /XBOUND := RADIUS; ,END; )YBOUND := YBOUND + SIZE + 2.0; )PLOT(0.0, RADIUS + 1.0, - 3);  + 6.0 * COS(PI / 8N)) /ELSE 2DIVISOR := 2.0 ,END )ELSE ,DIVISOR := 1.0; )S0 := SIZE * 2 * SIN(PI / N) / DIVISOR; )SIDE[)PAGE(OUTPUT); )ERASE(DISSCR); )FLAKE(RADIUS, 0.0, 0.0, DEPTH, N, OUT); )PLOT(0.0, RADIUS + 1.0, - 3); )WRITE('Enter Depth, 1] := S0; )FOR I := 2 TO DEPTH DO ,SIDE[I] := SIDE[I - 1] / 3; { DETERMINE TURN ANGLES } )LOWTURN := SUB(- 2); )IF OUT )TNumber of sides, In or Out'); )READ(DEPTH, N, OUTC); )OUT := OUTC <> 'I'; &END; END {FLAKY}. ��������������������������������HEN ,HIGH1 := SUB(N - 2) )ELSE ,HIGH1 := SUB(2 - N); )IF OUT )THEN ,HIGH2 := SUB(- 2) )ELSE ,HIGH2 := SUB(2); { LOCATE �THE BEGINNING CORNER OF THE CURVE } )LEVEL := 1; )X0 := XINIT - S0 / 2; )X1 := X0; )Y0 := YINIT - S0 * COT(PI / N) / 2; ����)Y1 := Y0; )PLOT(X0, Y0, 3); )DIR := SUB(N - 2); { THEN WEND OUR WAY FROM VERTEX TO VERTEX OF THE BOTTOM-LEVEL N-GON } )XK��&��   { (Lowercase: convert a pascal program to lower case. This program copies its input file to its out�put file, changing all upper case characters to lower case, except for anything in quotes. } {$D3}  program �lowercase; var #infile, outfile: text; #name: string; #lc: integer; # procedure copychar; # #begin &if eoln(infile) &t�hen )begin .write('.'); .lc := lc + 1; .if lc mod 50 = 0 then writeln; .writeln(outfile) )end &else )begin ,outfile ^ :�����������������������������������������������������������������������������������������������������������������������O��^�= infile ^; ,put(outfile); )end; &get(infile); #end {copychar}; # # # #procedure initialize; #begin )page(output); )w�rite(' Input file:'); )readln(name); )reset(infile, concat(name, '.TEXT')); )write('Output file:'); )readln(name); )rewrite�(outfile, concat(name, '.TEXT')); " lc := 0; "end;  begin {lowercase} # #initialize; #while not eof(infile) do &b��egin )if infile ^ = '''' )then ,repeat /copychar; ,until infile ^ = '''' )else ,if infile ^ in ['A' .. 'Z'] then ���������.infile ^ := chr(ord(infile ^) + ord('a') - ord('A')); )copychar; &end; #close(outfile, lock); #writeln; #writeln('Done.')�; end {lowercase}.  �����������������������������������������������������������������������������������������������������������������'�� ��  { (Lowercase: convert a pascal program to lower case. This program copies its input file to its out�put file, changing all upper case characters to lower case, except for the first letter after a period. } {$D�3}  program lowercase; var #infile, outfile: text; #name: string; #UpShift : boolean; #lc: integer; # procedure copychar�; # #begin &if eoln(infile) &then )begin .write('.'); .lc := lc + 1; .if lc mod 50 = 0 then writeln; .writeln(outfile) �����������������������������������������������������������������������������������������������������������������������O��^�)end &else )begin ,outfile ^ := infile ^; ,put(outfile); )end; &get(infile); #end {copychar}; # # # #procedure initi�alize; #begin )page(output); )write(' Input file:'); )readln(name); )reset(infile, concat(name, '.TEXT')); )write('Output �file:'); )readln(name); )rewrite(outfile, concat(name, '.TEXT')); " UpShift := true; )lc := 0; "end;  begin {lower�case} # #initialize; #while not eof(infile) do &begin )UpShift := UpShift or (infile ^ = '.'); �����������������������������,if infile ^ in ['A' .. 'Z'] then .if not UpShift then 1infile ^ := chr(ord(infile ^) + ord('a') - ord('A')) .else 1UpShift�� := false; )copychar; &end; #close(outfile, lock); #writeln; #writeln('Done.'); end {lowercase}.  ����������������������������(�� �} )WriteLn('Best and Worst precisions are ', ,Epsilon, Epsilon * Base ); &end. & ( �����������������������������������������program InvestigateRepresentation;  var (Base, (NumberOfDigits, (I : integer; (Rounding : boolean; (epsilon : r�eal; ( #procedure Enquiry(var Radix, Digits : integer; var Rounds : boolean); #var (Number, (Increment : real; ( #begin �({ Find large integral value just beyond integer limits } (Number := 2; (while (((Number+1) - Number) = 1) do ,Number := Numb�er * 2; ( ({ Manufacture the next largest real value } (Increment := 2; (while Number + Increment = Number do ,Increment :=�����������������������������������������������������������������������������������������������������������������������O��^� 2 * Increment; ( ({ Subtract these to give radix of representation } (Radix := trunc( (Number + Increment) - Number ); ( (����������������������������������������������������������������������������������������������������������������������������{See if it rounds or truncates by adding (radix-1) } (Rounds := (Number + (Radix - 1) ) <> Number ; ({ Work out how many digit�s in mantissa } (Digits := 0; (Number := 1; ( (while ((Number + 1) - Number) = 1 do *begin -Digits := Digits + 1; -Number� := Number * Radix; *end; %end { Enquiry }; % %begin )Enquiry( Base, NumberOfDigits, Rounding ); )WriteLn; )WriteLn; �����)WriteLn('Base=', Base : 5); )Write('Number of base ', Base, ' Digits=', NumberOfDigits : 5); )if Rounding then ,Writeln(' (� Rounded )') )else ,WriteLn(' ( Truncated )'); ) ){ Compute the precision bounds } )Epsilon := 1; )for I := 1 to NumberOfD�igits do ,Epsilon := Epsilon / Base; ) )if Rounding then -Epsilon := Epsilon / 2; ) ){ Print the best and worst precision ��)�� ee = (yes, no, maybe); 'line = packed array [ 1..10000 ] of char; 'dual = record 2case three of 5yes: ( a: ^ integerinit; & &begin )init1; gr1 [ 1 ] := 'mov'; gr1 [ 2 ] := 'cmp'; ����������������������������������������������������������); 5no: ( i: integer); 5maybe: ( c: ^ line); /end; &forms = (decim, octal, ascii, str, code); &table = arra)gr1 [ 3 ] := 'bit'; gr1 [ 4 ] := 'bic'; gr1 [ 5 ] := 'bis'; )gr1 [ 6 ] := 'add'; gr1 [ 9 ] := 'movb'; gr1 [ 10 ] := 'y [ 0..15 ] of string [ 5 ]; # var &comset: set of char; $nextline, &gotnum: integer; )num: packed array[1..10] of char; )cmpb'; )gr1 [ 11 ] := 'bitb'; gr1 [ 12 ] := 'bicb'; gr1 [ 13 ] := 'bisb'; )gr1 [ 14 ] := 'sub'; gr2 [ 1 ] := 'br'; gr2{ ODT : Octal Debugging tool George Gonzalez (C) 1979 University of Minnesotaadr: dual; &format: forms; (regs: array [ 0..7 ] of packed array [ 1..2 ] of char; )fpo, )gr1, )gr2, )gr3, )gr4, )gr5,  ODT/Pascal is a machine language debugging tool. Commands: nnn)gr6, )gr7, )gr8, )gr9, (gr10, (gr11, (gr12, (gr13, (grcc: table; procedure initialize; # # #procedure init1; & &nnn/ Inspect location nnnnnn ^ or - Inspect previous location line feed Inspect next lo &procedure zip(var a: table); ) )var 4i: integer; , )begin ,for i := 1 to 15 do /a [ i ] := 'oops'; )end {zip}; & ���cation nnnnnn <cr> Deposit nnnnnn in current location @ Go inspect location pointed to by cu& &begin {[b+]} )zip(gr1); zip(gr2); zip(gr3); zip(gr4); zip(gr5); zip(gr6); )zip(gr7); zip(gr8); zip(gr9); rrent location > Go inspect location specified by this relative branch O zip(gr10); zip(gr11); )zip(gr12); zip(gr13); zip(grcc); zip(fpo); fpo [ 0 ] := 'fadd'; )fpo [ 1 ] := 'fsub'; fpo [ Set octal display D Set decimal display A Set ASCII display S  2 ] := 'fmul'; fpo [ 3 ] := 'fdiv'; )gr13 [ 0 ] := 'rorb'; gr13 [ 1 ] := 'rolb'; gr13 [ 2 ] := 'asrb'; )gr13 [ 3 ] := ' Set string display C Set code ( machine code ) display : Display curaslb'; gr13 [ 5 ] := 'mfpd'; gr13 [ 6 ] := 'mtpd'; )gr9 [ 0 ] := 'halt'; gr9 [ 1 ] := 'wait'; gr9 [ 2 ] := 'rti'; )gr9rent location in octal. = Display current location in decimal ������������������������������������������ [ 3 ] := 'bpt'; gr9 [ 4 ] := 'iot'; gr9 [ 5 ] := 'reset'; )gr9 [ 6 ] := 'rtt'; regs [ 0 ] := 'r0'; regs [ 1 ] := 'r1'; ' Display current location as ASCII ; Display current location as machine code  )regs [ 2 ] := 'r2'; regs [ 3 ] := 'r3'; regs [ 4 ] := 'r4'; )regs [ 5 ] := 'r5'; regs [ 6 ] := 'sp'; regs [ 7 ] := ' Q Exit ODT } {$D3} {[a=10,q=1,p=4]} { } program odt; const )cr = 13; )lf = 10; # type &thrpc'; )grcc [ 0 ] := 'c'; grcc [ 1 ] := 'v'; grcc [ 2 ] := 'z'; )grcc [ 3 ] := 'n'; &end {init1}; # # # # #procedure �*��  &adr.i := 0; &format := octal; &writeln(' ODT/Pascal 0.5'); &write('@'); #end {initialize}; function branch: integer; #; /if zeroes then 2write(dig [ i ]); ,end; &end {numout}; # # #procedure charout; & &begin )write(v.c [ 1 ], v.c [ 2 ] #var ,off: integer; & #begin &off := adr.a ^ mod 256; &if off > 127 then )off := off - 255; &branch := adr.i + off * 2 ); &end {charout}; # # #procedure strout; & &var 1j: integer; & & &function parity(c: char): char; ) )begin ��������+ 2; #end {branch}; procedure setval(var a: integer);   var stop, i, j: integer; $r: packed record case integer of *1: (,parity := chr(ord(c) mod 128); )end {parity}; & & &procedure writechar(c: char); ) )begin ,c := parity(c); ,if ord(c)  oct: packed array [0..4] of 0..7); *2: ( int: integer); *3: ( bit: packed array [0..15] of 0..1) 'end; # #begin &i := 0; > 0 then /if ord(c) < 32 /then 2write('^', chr(ord(c) + ord('A') - 1)) /else 2write(c); )end {writechar}; & & &begin {s&j := gotnum; &stop := 0; &r.int := 0; &if gotnum > 5 then )if num[1] = '1' then ,begin /stop := 1; /r.bit[15] := 1; ,etrout} )j := 1; )while (j <= 60) and (parity(adr.c ^ [ j ]) <> chr(cr)) do ,begin /writechar(adr.c ^ [ j ]); /j := j + 1; nd )else ,begin /stop := 999; /write(' ish ') ,end; &while j > stop do )begin ,r.oct[i] := ord(num[j]) - ord('0'); ,i :,end; )nextline := j + adr.i; &end {strout}; # # #procedure decode(word: integer); & & &procedure illop; ) )begin ,wr [ 2 ] := 'bne'; )gr2 [ 3 ] := 'beq'; gr2 [ 4 ] := 'bge'; gr2 [ 5 ] := 'blt'; )gr2 [ 6 ] := 'bgt'; gr2 [ 7 ] := 'ble'; = i + 1; ,j := j - 1; )end; &if gotnum <> 0 then a := r.int; &gotnum := 0; #end {setval}; ������������������������������� gr11 [ 0 ] := 'bpl'; )gr11 [ 1 ] := 'bmi'; gr11 [ 2 ] := 'bhi'; gr11 [ 3 ] := 'blos'; )gr11 [ 4 ] := 'bvc'; gr11 [ 5 ] procedure out(n: integer; format: forms; zeroes: boolean); # #var .v: record 5case forms of 8decim: ( i: integer); := 'bvs'; gr11 [ 6 ] := 'bcc'; )gr11 [ 7 ] := 'bcs'; gr5 [ 0 ] := 'clr'; gr5 [ 1 ] := 'com'; )gr5 [ 2 ] := 'inc'; gr5 8octal: ( o: packed array [ 1..16 ] of 0..1); 8ascii: ( c: packed array [ 1..2 ] of char); 2end; # # #proc[ 3 ] := 'dec'; gr5 [ 4 ] := 'neg'; )gr5 [ 5 ] := 'adc'; gr5 [ 6 ] := 'sbc'; gr5 [ 7 ] := 'tst'; )gr6 [ 0 ] := 'ror'; edure numout; & &var 1i: integer; /dig: array [ 1..6 ] of char; & & &function num(ind: integer): char; ) )begin ,with gr6 [ 1 ] := 'rol'; gr6 [ 2 ] := 'asr'; )gr6 [ 3 ] := 'asl'; gr6 [ 4 ] := 'mark'; gr6 [ 5 ] := 'mfpi'; )gr6 [ 6 ] := 'mtv do /num := chr(o [ ind ] + o [ ind + 1 ] * 2 + o [ ind + 2 ] * 4 + 2ord('0')); )end {num}; & & &begin {numout} )with v pi'; gr6 [ 7 ] := 'stx'; &end {init}; {[b-]} # # #begin {initialize} &init; &gotnum := 0; ������������������������������do ,begin /dig [ 1 ] := chr(o [ 16 ] + ord('0')); /dig [ 2 ] := num(13); /dig [ 3 ] := num(10); /dig [ 4 ] := num(7); /dig&comset := [ chr(cr), ' ', chr(lf), '^', '-', '/', '@', ':', '>', '''', )';', 'C', 'Q', 'S', 'A', 'O', 'D', '=', '0' .. '7' ]; [ 5 ] := num(4); /dig [ 6 ] := num(1); ,end; )for i := 1 to 6 do ,begin /zeroes := zeroes or (dig [ i ] <> '0') or (i = 6)�+�� &procedure outopr(c: integer); ) )var 1mode, -register: 0..7; ) ) )procedure reg(pre, suf: string); , ,begin /write(p3; ) ) )procedure group2; , ,var 6op: 0..7; / , ,procedure group4; / / /procedure group7; 2 2 2procedure gr71(s: re, regs [ register ], suf); ,end {reg}; ) ) )procedure nextword(offset: integer); , ,begin /adr.i := adr.i + 2; /out(ofstring); 5 5var @i: integer; 8 5begin 8for i := 0 to 3 do ;if bits(i, i) = 1 then >write(s, grcc [ i ], ' '); 5end {gr7fset + adr.a ^, octal, false); /nextline := adr.i + 2; ,end {nextword}; ) ) )begin {outopr} ,mode := bitsof(3, 5, c); ,re1}; 2 2 2begin {group7} 5case bits(4, 5) of 80: ;write(gr9 [ bits(0, 2) ]); 81: ;illop; 82: ;gr71('cl'); 83: ��������gister := bitsof(0, 2, c); ,if register = 7 ,then /begin 2case mode of 50: 8reg('', ''); 51: 8reg('(', ')'); 52: 8begi;gr71('se'); 5end; 2end {group7}; / / /begin {group4} 2case bits(6, 7) of 50: 8group7; 51: 8opr1('jmp'); 52: 8if bin ;write('#'); ;nextword(0); 8end; 53: 8nextword(0); 54, 5: 8begin ;if odd(mode) then >write('@'); ;reg('-(', ')'); 8ts(3, 5) = 0 8then ;write('rts ', regs [ bits(0, 2) ]) 8else ;illop; 53: 8opr1('swab'); 2end; /end {group4}; , , ,begend; 56, 7: 8begin ;if odd(mode) then >write('@'); ;nextword(adr.i + 4); 8end; 2end; /end ,else /if mode = 1 /then 2in {group2} /op := bits(8, 10); /if op = 0 /then 2group4 /else 2reljmp(gr2 [ bits(8, 10) ]); ,end {group2}; ) ) )procereg('(', ')') /else 2begin 5if odd(mode) then 8write('@'); 5case mode of 80, 1: ;reg('', ''); 82, 3: ;reg('(', ')+'); dure group3; , ,begin /case bits(9, 10) of 20: 5reg1('jsr'); 21: 5opr1(gr5 [ bits(6, 8) ]); 22: 5opr1(gr6 [ bits(6, 8) 84, 5: ;reg('-(', ')'); 86, 7: ;begin >nextword(0); >reg('(', ')'); ;end; 5end; 2end; )end {outopr}; & & ������������]); 23: 5illop; /end; ,end {group3}; ) ) )begin {group23} ,if bits(11, 11) = 0 ,then /group2 ,else /group3; )end {g&procedure reg1(opc: string); ) )begin ,write(opc, ' ', regs [ bits(6, 8) ], ','); ,outopr(bits(0, 5)); )end {reg1}; & &roup23}; & & &procedure group10; ) )begin ,case bits(9, 11) of /0: 2reg1('mul'); /1: 2reg1('div'); /2: 2reg1('ash');ite('??'); )end {illop}; & & &function bitsof(lo, hi, word: integer): integer; ) )var 2tot, 4i: integer; 1both: record  &procedure reljmp(op: string); ) )begin ,write(op, ' '); ,out(branch, octal, false); )end {reljmp}; & & &procedure opr;case boolean of >true: ( i: integer); >false: ( b: packed array [ 0..15 ] of J0..1); 8end; , )begin ,t1(opc: string); ) )var .saveadr: integer; , )begin ,saveadr := adr.i; ,write(opc, ' '); ,outopr(bits(0, 5)); ,adr.i := ot := 0; ,both.i := word; ,for i := hi downto lo do /tot := 2 * tot + both.b [ i ]; ,bitsof := tot; )end {bits}; & & &fusaveadr; )end {opr1}; & & &procedure opr2(opc: string); ) )var .saveadr: integer; , )begin ,saveadr := adr.i; ,write(nction bits(lo, hi: integer): integer; ) )begin ,bits := bitsof(lo, hi, word); )end {bits}; & & ��������������������������opc, ' '); ,outopr(bits(6, 11)); ,write(','); ,outopr(bits(0, 5)); ,adr.i := saveadr; )end {opr2}; & & &procedure group2�,��  5write('sob ', regs [ bits(6, 8) ], ','); 5out(adr.i + 2 - bits(0, 5) * 2, octal, false); 2end; ,end; )end {group10}; & �&setval(adr.a ^); #end {setmem}; procedure linefeed; # #begin &setmem; &if format in [ code, str ] &then )newplace(nex& &procedure group1123; ) )begin ,case bits(11, 11) of /0: 2reljmp(gr11 [ bits(8, 10) ]); /1: 2case bits(9, 10) of 50:tline, ' ') &else )newplace(adr.i + 2, ' '); #end {linefeed}; procedure return; # #begin &setmem; &writeln; &write('@' 8begin ;if bits(8, 8) = 0 ;then >write('emt ') ;else >write('trap '); ;out(bits(0, 7), octal, false); 8end; 51: 8opr1); #end {return}; procedure uparrow; # #begin &newplace(adr.i - 2, '^'); #end {uparrow}; procedure atsign; # #begin (concat(gr5 [ bits(6, 8) ], 'b')); 52: 8if bits(8, 8) = 0 8then ;opr1(concat(gr6 [ bits(6, 7) ], 'b')) 8else ;illop; 53: &newplace(adr.a ^, '@'); #end {atsign}; procedure greater; # #begin &newplace(branch, '>'); #end {greater}; �����������8illop; 2end; ,end; )end {group1123}; & & &begin {decode} )nextline := adr.i + 2; )case bits(12, 15) of ,0: /group23;procedure getnumber; # #begin &write(output, keyboard ^); &gotnum := gotnum + 1; &num[gotnum] := keyboard ^; #end {getnumb ,7: /group10; ,8: /group1123; ,15: /illop; ,1, 2, 3, 4, 5, 6, 9, 10, 11, 12, 13, 14: /opr2(gr1 [ bits(12, 15) ]); )ender}; procedure badcommand; # #begin &gotnum := 0; &writeln('?'); &write('@'); #end {badcommand}; begin {odt} #initial; &end {decode}; # # #begin {out} &v.i := n; &case format of )octal: ,numout; )ascii: ,charout; )decim: ,write(' ', ize; #repeat &get(keyboard); &if keyboard ^ in [ 'a' .. 'z' ] then )keyboard ^ := chr(ord(keyboard ^) + ord('A') - ord('a'))n); )str: ,strout; )code: ,decode(n); &end; #end {out}; procedure update; # #begin &write('@'); &out(adr.i, octal, t; &if keyboard ^ in comset &then )begin ,case keyboard ^ of /'/': 2slash; /'0', '1', '2', '3', '4', '5', '6', '7': 2getnrue); &write('/ '); &out(adr.a ^, format, true); &write(' '); #end {update}; procedure slash; # #begin &write('/ '); ��umber; /'-', '^': 2uparrow; /'''': 2quote; /'=': 2equals; /';': 2semicolon; /':': 2colon; /'D': 2format := decim; /&setval(adr.i); &out(adr.a ^, format, true); #end {slash}; procedure quote; # #begin &out(adr.a ^, ascii, true); #end {'O': 2format := octal; /'A': 2format := ascii; /'S': 2format := str; /'C': 2format := code; /'Q': 2writeln('Bye'); /'@quote}; procedure semicolon; # #begin &out(adr.a ^, code, true); #end {semicolon}; procedure colon; # #begin &out(adr': 2atsign; /' ': 2return; /'>': 2greater; ,end; ,case ord(keyboard ^) of /cr: 2return; /lf: 2linefeed; ,end; )end .a ^, octal, true); #end {semicolon}; procedure equals; # #begin &out(adr.a ^, decim, true); #end {equals}; procedure n&else )badcommand; #until keyboard ^ = 'Q'; end {odt}. ���������������������������������������������������������������������� /3: 2reg1('ashc'); /4: 2reg1('xor'); /5: 2write(fpo [ bits(3, 4) ], ' ', regs [ bits(0, 2) ]); /6: 2illop; /7: 2beginewplace(a: integer; c: char); # #begin &writeln(c); &adr.i := a; &update; #end {newplace}; procedure setmem; # #begin �-�� Tab 4then 8Out('TAB') 4else 8if C = Return 8then <Out('RETURN') 8else <if C = RubOut <then @Out('RUBOUT') <else @if procedure ExitTextMode(NotAtMargin: Boolean); $forward; procedure Abort; $ $begin (InitKbdRead; (Message3(ThisCommand,C = LineFeed @then DOut('LINE FEED') @else Dif C = Escape Dthen FOut('ESCAPE') Felse @begin FOut('CTRL-'); FChOut(chr( ' command aborted', '!!'); (if InTextMode then ,ExitTextMode(True); (exit(InputCommand); $end {Abort}; procedure Twidd�����������������������������������������������������������������������������������������������������������������������O��^�ord(C) + ord('A') - 1)); 4 end; 4Out('}'); 0end ,else 0ChOut(C); (end {ControlOut}; $    procedure Defi�neMicro { MikChar : char ; var MicStr : Longstring } { Create a micro }; $ $var 9p: ^ LongString; ( $begin (if Micro [ Mik�Char ] = nil then ,begin 0new(p); 0Micro [ MikChar ] := p; ,end; (Micro [ MikChar ] ^ := MicStr; $end {DefineMicro}; �� function UpperCase(c: char): char; $ $begin (if c in [ 'a' .. 'z' ] (then ,UpperCase := chr(ord(c) - ord('a') + ord('A')) �(else ,UpperCase := c; $end {UpperCase}; procedure UpperIt(var S: string) { map S to Upper Case }; $ $var 9I: integer�; ( $begin (for I := 1 to Length(S) do ,S [ I ] := UpperCase(S [ I ]); $end {UpperIt}; procedure InitKbdRead { initiat�e read from keyboard }; $ $begin (UnitClear(Console); (UnitRead(Console, KeyBuffer, 1,, 1); $end {InitKbdRead}; procedur�e message(S: string) { Print S with trimmings }; $ $begin (WriteLn; (WriteLn(Bell, '{ ', S, ' }'); $end {message}; pro$ $ $procedure ControlOut{C: char} { Print name of control character }; ( (procedure out( S : string ); (begin 0Write( S cedure message3(a, b, c: string) { print 3 part message }; $ $begin (message(concat(a, b, c)); $end {message3}; functio); 0Col := Col + Length( S ); (end; ( (procedure Chout( C : char ); (begin 0Write( C ); 0Col := Col + 1; (end; ( (begin nextChar: char { Return last keyboard character }; $ $begin (LastChar := chr(ord(KeyBuffer [ 1 ]) mod CharRange); (NextChan ,if Col > 65 then ,begin 0WriteLn; 0Write(' '); 0Col := 3; ,end; ,if ord(C) < 32 ,then 0begin 4Out('{'); 4if C = r := LastChar; $end {nextChar}; procedure InputCommand(c: char); $forward; ������������������������������������������.��  modem }; $ $begin (while not (Ready in IoPort ^.OutputCSR) do { Wait for it } ,; (IoPort ^.OutputData := c; (if Ready in tKbdRead; (unitwait(Console); (c := NextChar; (Write(c); $end {readc}; ���������������������������������������������������IoPort ^.InputCSR then ,MoveChar; $end {SendChar}; procedure Echo(c: char) { Echo c to screen and line }; $ $begin (if�����������������������������������������������������������������������������������������������������������������������O��^� HalfDuplex then ,begin 0chh [ 1 ] := c; 0UnitWrite(SysTerm, chh, 1, 0, 1); ,end; (SendChar(c); $end {Echo}; procedur���IB;�����������������������������������������������������������������������������������������������������������������������e SendAndEcho(c: char) { Echo c to screen and line }; $ $begin (if HalfDuplex then ,Write(c); (SendChar(c); $end {Echo}; � procedure Quiet(Delay: integer); $ $var 9T: integer; ( $begin (T := 0; (repeat ,Twiddle; ,T := T + 1; ,if Ready in�le { Idle loop }; $ $begin (if not UnitBusy(Console) then ,if NextChar = Escape ,then 0Abort ,else 0InitKbdRead; $end { IoPort ^.InputCSR then 0begin 4T := 0; 4MoveChar; 0end; (until T > Delay; $end {Quiet}; ����������������������������Twiddle}; procedure NewOpen(fn: NameString) { Open output file }; $ $begin (UpperIt(fn); (if pos(TextSuffix, fn) = 0 thprocedure Await(Target: char) { wait for a particular char }; $ $var 6Done: boolean; 9T: integer; ( $begin (Done := falseen ,fn := concat(fn, TextSuffix); (Close(Fil); {$I-} (rewrite(Fil, fn); {$I+} (if ioresult <> 0 then ,begin 0Message3('Can; (T := 0; (repeat ,repeat 0Twiddle; 0T := T + 1; 0Done := T > TimeOut; ,until Ready in IoPort ^. ,InputCSR; ,MoveChar;''t open ', fn, '!!'); 0Abort; ,end; $ OutFileName := Fn; $end {NewOpen}; function Modem: char { return next Modem c (until Ch = Target; (if Done then ,Message('Host didn''t respond'); $end {Await}; procedure Send(S: string) { Write S har }; $ $begin (repeat ,Twiddle (until Ready in IoPort ^. (InputCSR; (Modem := chr(IoPort ^.InData mod CharRange); $endto line and screen }; $ $var 9I: integer; ( $begin (for I := 1 to Length(S) do ,SendAndEcho(S [ I ]); (SendAndEcho(Retur {Modem}; procedure MoveChar { Move char from modem output to screen }; $ $begin { MoveChar } ���������������������������n); $end {Send}; procedure SendWait(S: string) { Send S and Await handshake }; $ $begin (Send(S); (Await(PromptChar); (ch := chr(IoPort ^.InData mod CharRange); (if not ((ch = RubOut) or (ch = Null) or (ch = LineFeed)) then ,begin { prt } 0ch$end {SendWait};  procedure PutChar(c: char) { Send c to line, count columms }; $ $begin (Echo(c); (ColumnPosition := Ch [ 1 ] := ch; 0UnitWrite(SysTerm, chh, 1, 0, 1); ,end { prt }; $end {MoveChar}; procedure SendChar(c: char) { Send c toolumnPosition + 1; $end {PutChar}; procedure readc(var c: char) { get and Echo next Keyboard character }; $ $begin (Ini�/�� .DATA.TEXT'; +PromptChar = '/'; .SysTerm = 1; .Console = 2; ,BreakCode = 2; ,BreakTime = 60; -LineSize = 250; 0Delay = 10NameString; 3Fil: text; 0IoPort: ^ Device; 1Micro: MicroInfo; 1trick: DualEntity; /CharBuf: SaveBuffer; ,ErrorCache: Error00; .MinChar = 0; .MaxChar = 255; ,CharRange = 128; .TimeOut = 10000; .EditMax = 15000; /MaxBuf = 15000; -ErrorMax = 10; Info; $ procedure ReadMicro(var F: text; var S: Longstring ; �������������������������������������������������������������-MaxTries = 3; .NestMax = 5; $ type +NameString = string [ 30 ]; +LongString = string [ LineSize ]; -UnitWord = packed arr4Self: char ; EchoChar, SpecialFile :boolean) { Read string }; $forward;  procedure ControlOut(C: char) { Print name of contay [ 1..2 ] of char; +SaveBuffer = packed array [ 0.. MaxBuf ] of char; ,MicroInfo = array [ char ] of ^ LongString; $StatusCrol character };forward;  procedure DefineMicro(MikChar: char; var MicStr: Longstring);forward;   function YesNo( S : strinontrolBits = (BreakBit, b1, b2, b3, b4, b5, b6, Ready, 9b8, b9, b10, b11,b12, b13, b14, CarrierDetect); 1ControlSet = set of Sg ) : boolean ; forward;  segment procedure Micros { Handle Micro options }; $ $var 8Ch, 1MicroChar: char; ( $ $ $ $tatusControlBits; /Device = record GInputCSR: ControlSet; IInData: integer; FOutputCSR: ControlSet; EOutputData: char 9end $function UpperCase(c: char): char { Return uppercase character }; ( (begin ,if c in [ 'a' .. 'z' ] ,then 0UpperCase := c; +DualEntity = record =case boolean of Afalse: ( IoPtr: ^ Device); Atrue: ( I: integer) �����hr(ord(c) - ord('a') + ord('A')) ,else 0UpperCase := c; (end {UpperCase}; $ $ $ $ $ $procedure message(S: string) { Pri9end; $ (ErrorRecord = record :Starting, <Ending: Integer; 6end; $ ErrorInfo = array [1..ErrorMax] of ErrorRecord; $ vnt S with trimmings }; ( (begin ,WriteLn; ,WriteLn(Bell, '{ ', S, ' }'); (end {message}; $ $ %Procedure EnforceMargin; �ar 3Col, -DumpLines, )BufferPointer, (ColumnPosition, ,PressLevel, ,ErrorCount, -CharCount: integer; 3Tab, 0Suffix, 2E�xOn, 2Bell, +StartOfText, ,EndOfBlock, -EndOfText, -BackSpace, 0RubOut, 0Escape, /LowChar, .HighChar, .LastChar, 2Nul�l, ,SpaceEater, 0Return, .LineFeed, +CommandChar, 4ch, 5C: char; +NeedCommand, +ModemStatus, )OverflowCheck, 2Quit, ,�SavingText, ,InTextMode, ,HalfDuplex: boolean; /OkaySet, /NullSet, /QuitSet, ,CommandSet: set of char; -KeyBuffer, 3chh:const .Version = '2.0'; +TextSuffix = '.TEXT'; *DefaultChar = '\'; %DefaultDirectives = 'BATCH|X.NXFER,~'; -InitName = 'COM UnitWord; 0Prompt, 'TransferCommand, +OutFileName, +ThisCommand: string; .HostFile, /RawName, ,GlobString, -GlobSText: �0�� ,MicroChar := Keyboard ^; ,ControlOut(MicroChar); ,WriteLn; ,Write('Enter Micro string for '); ,ControlOut(MicroChar); ,Wr; )AsciiStartOfText = 2; +AsciiTextEndOf = 3; 0AsciiBell = 7; +AsciiBackSpace = 8; 1AsciiTab = 9; ,AsciiLineFeed = 10; .Aite(' , end with '''); ,ControlOut( CommandChar ); ,ControlOut( CommandChar ); ,WriteLn(''':'); ,Col := 0; ,Readmicro(KeybosciiReturn = 13; 'AsciiHorizontalTab = 16; 1AsciiXOn = 17; *AsciiBlockEndOf = 23; .AsciiEscape = 27; .AsciiRubOut = 127; 2ard, GlobString, MicroChar, true, false); ,WriteLn; ,MicStr := ' '; ,MicStr [ 1 ] := MicroChar; ,if GlobString = MicStr ,thMaxChar = 255; ( $ $ $ $ $procedure SerialAddress(var A: integer) { Find port address }; ( (const 5PassWord = 12345; ��en { Assume null case } 0Micro [ MicroChar ] := nil ,else 0begin 6DefineMicro(MicroChar, GlobString); 6Col := 0; 6Write('M2TrapAddress = 4; 2FlagAddress = 0; *ReturnFromInterrupt = 2; , (type 3DualEntity = record Ecase boolean of Ifalse: ( icro character '); 6ControlOut(MicroChar); 6Writeln(' defined.'); 0end; (end {MakeMicro}; $ $ $ $ $ $procedure ListMic P: ^ integer); Itrue: ( I: integer) Aend; 9code = array [ 1..3 ] of integer; , (var 6SaveFlag, 6SaveTrap, :Juro { List active Micros }; ( (var =I: integer; <ch: char; , (begin ,Col := 0; ,for ch := LowChar to HighChar do 0if Micnk, =I, ;Max, =T: integer; :list: array [ 0..8 ] of integer; 9trick: DualEntity; ;ptr: ^ code; , ( ( ( ( (function oro [ ch ] <> nil then 4begin 8ControlOut(ch); 8Write(':'); 8for I := 1 to Length(Micro [ ch ] ^) do BControlOut(Micro [ ch ctal(S: string): integer { Convert string to integer }; , ,var AI, AT: integer; 0 ,begin 0T := 0; 0for I := 1 to Length(] ^ [ I ]); 8Writeln; 8Col := 0; 4end; (end {ListMicro}; $ $ $ $ $ $procedure ClerMicro { Clear all Micros }; ( �����S) do 4T := T * 8 + ord(S [ I ]) - ord('0'); 0octal := T; ,end {octal}; ( ( ( ( ( (Procedure SetUp(val: string) { Make (var <ch: char; , (begin ,for ch := LowChar to HighChar do 0Micro [ ch ] := nil; ,Message('All Micros cleared'); (end {Ca list entry }; , ,begin 0Max := Max + 1; 0list [ Max ] := Octal(val); ,end {SetUp}; ( ( ( ( ( (function peek(adr: inlerMicro}; $ $ $ $ $ $begin {Micros} (repeat ,Write('Micros: Define, List, Quit, or Clear?'); ,get(input); ,ch := Uppeteger): integer { Peek into raw memory }; , ,var =trick: DualEntity; 0 ,begin 0trick.i := adr; 0peek := trick.p ^; ,end rCase(input ^); ,WriteLn; ,if ch in [ 'D', 'L', 'C' ] then 0case ch of 4'D': 8MakeMicro; 4'L': 8ListMicro; 4'C': 8if Ye{peek}; ( ( ( ( ( (procedure poke(adr, val: integer) { Poke a value into raw memory }; , ,var =trick: DualEntity; 0 ��%begin 'if Col > 70 then 'begin ,Col := 3; ,WriteLn; ,Write(' '); 'end; $end; $ $ $ $procedure MakeMicro { Create a sNo('Are you sure you want to clear all Micros?') 9then ClerMicro; 0end; ,WriteLn; (until ch = 'Q'; (Message('Exit Micro moMicro string }; ( (var 8MicStr: string; , (begin ,Col := 0; ,Write('Micro character?'); ,get(Keyboard); ����������������de.'); $end {Micros}; ( ( segment procedure Initialize { Initialize program }; $ $const 2MinChar = 0; 0AsciiNull = 0�1�� ile); @case C of D'C': ICommandChar := InitFile^; D'D': HHalfDuplex := InitFile ^ = '+'; D'O': HOverflowCheck := InitFile CommandSet := [ 'C','D','G','H','L', 'M','O','P','Q','R','S','U','W' ]; QuitSet := [ E,begin 0trick.i := adr; 0trick.p ^ := val; ,end {poke}; ( ( ( ( ( (BEGIN {SerialAddress} ,Max := 0; ,SetUp('177570') ^ = '+'; D'M': HGetMicro; D'X': ReadLn( InitFile, TransferCommand ); D' ': { ignore }; @end; <end 8else <Writeln('Bad i; ,SetUp('176570'); ,SetUp('176560'); ,SetUp('177530'); ,SetUp('177520'); ,SetUp('176530'); ,SetUp('176520'); ,SetUp('177nit directive:', InitFile ^); 8readln(InitFile); 4end; 0WriteLn; ,end {ReadInfo}; ( ( ( ( ( (begin {$I-} ,reset(InitF560'); ,new(ptr); ,ptr ^ [ 1 ] := octal('005037') { clr @(pc)+ }; ,ptr ^ [ 2 ] := FlagAddress; ,ptr ^ [ 3 ] := ReturnFromIntile, InitName); ,if IoResult = 0 then 0ReadInfo 0else 2begin 9reset(InitFile, concat('*', InitName) ); ��������������������errupt; ,SaveFlag := Peek(FlagAddress); ,SaveTrap := Peek(TrapAddress); ,poke(TrapAddress, ord(ptr)); ,T := 0; ,repeat 0T 9if IoResult = 0 then <ReadInfo; 2end; ({$I+} (end {ReadDefaults}; $ $ $ $ $ $begin {Initialize} {[F-]} { := T + 1; 0poke(0, PassWord); 0A := list [ T ]; 0Junk := peek(A); ,until (Peek(0) = PassWord) or (T >= Max); ,Poke(TrapAddr Switch Options } Quit := false; SavingText := false; HalfDuplex := false; ess, SaveTrap); ,Poke(FlagAddress, SaveFlag); (end {SerialAddress}; $ $ $ $ $ $procedure ReadDefaults { Read init file } NeedCommand := false; (OverflowCheck:= true; { Important characters } EndOfText := c; ( (var =C: char; 6InitFile: text; , ( ( ( ( (procedure ReadInfo; , , , , , ,procedure GetMicro { Define a micrhr(AsciiTextEndOf); EndOfBlock := chr(AsciiBlockEndOf); StartOfText := chr(AsciiStartOfText); o from init file }; 0 0var CMik: Char; 4 0begin 3if InitFile^ = '^' then 5begin 9get(InitFile); ������������������������ ExOn := chr(AsciiXOn); Tab := chr(AsciiTab); BackSpace := chr(AsciiBackSpace); 9if InitFile^ <> '^' then ;InitFile^ := Chr( Ord(InitFile^) - Ord('@') ); 5end; 2Mik := InitFile ^; 2get(InitFile); 2ReadM RubOut := chr(AsciiRubOut); Escape := chr(AsciiEscape); Return := chr(AsciiReturn)icro(InitFile, Globstring, Mik, false, InitFile^ = '=' ); 2DefineMicro(Mik, GlobString); 0end {GetMicro}; , , , , , ,beg; LineFeed := chr(AsciiLineFeed); Bell := chr(AsciiBell); Null := chr(Asciiin {ReadInfo} 0Write('Initializing'); 0if InitFile^ = '*' then 4ReadLn( InitFile ); 0while not eof(InitFile) do 4begin 8WrNull); SpaceEater := chr(AsciiHorizontalTab); LowChar := chr( MinChar ); ������������������������ite('.'); 8C := InitFile ^; 8if C in [ ' ', 'C', 'D', 'O', 'M', 'X' ] 8then <begin @get(InitFile) { Skip ':' }; @get(InitF HighChar := chr( MaxChar ); CommandChar := DefaultChar;  { Useful Sets } �2�� file from other Computer to TERAK.'); ,PrintLn('S Send file from TERAK to other Computer.'); ,Options('D Toggle Half-Duple�x.', HalfDuplex); WriteLn; ,PrintLn('H Prints this help list.'); ,PrintLn('Q Exit COM.'); ,WriteLn; ,WriteLn(' <Esc> key� Escapes one from any command.'); ,WriteLn; ,WriteLn(' Some other commands:'); ,Writeln; ,PrintLn('L List file to oth�er Computer.') { jte }; ,Options('R Record text from other Computer.', SavingText); ( Write('( '); ,if BufferPointer > 0�ndOfText, EndOfBlock ]; NullSet := [ chr(0) .. ' ', RubOut ] - [ Return ]; OkaySet := [ '!' .. '~' ]  then /WriteLn( BufferPointer div ( MaxBuf div 100 ), '% full )') ,else /WriteLn('empty )'); �������������������������������� { ascii printing chars } + [ Tab, Bell,BackSpace ] {common control chars }; { ,PrintLn('C Clear text from Record Buffer.'); ,PrintLn('W Write Record Buffer to a file.'); ,Options('O Toggle file ove Miscellaneous } (SerialAddress(Trick.I); (for c := LowChar to HighChar do ,Micro [ c ] := nil; (IoPort := Trickrflow handling.', Overflow); Writeln; ,PrintLn('P Change command Prefix character.'); ,PrintLn('M Micro Mode. Define, List.IoPtr; (CharBuf[ 0 ] := '?' { Sentinel }; (TransferCommand := DefaultDirectives; (ModemStatus := not (CarrierDetect in IoPo or Clear Micros.'); ,PrintLn('U Update Info file with current COM status.'); (end {help}; ��������������������������������rt ^.OutputCSR); (BufferPointer:= 0; (PressLevel := 0; (c := ' '; (InTextMode := false; (ReadDefaults; {[F+]�} $end {Initialize}; segment procedure Help; $ $ $ $ $ $procedure Options(S: string; Flag: boolean); ( (begin �����,ControlOut( CommandChar ); ,Write(S, ' { Currently '); ,if Flag ,then 0Write('ON }') ,else 0Write('OFF }'); (end {Optio�ns}; $ , ,procedure PrintLn( S : string ); ,begin + Col := 0; 2ControlOut( CommandChar ); $ WriteLn( S� ); ,end; , , ( (begin ,WriteLn; ,WriteLn(' < COM Options > Version ', Version); ,WriteLn; ,PrintLn('G Get ��3��  0.. progmax; #definitions: array [ 1..26 ] of integer; &calstack: array [ 1.. nestmax ] of integer; )stack: array [ 1.. nest �������������������������������������������������������������������������������������������������������������������������������max ] of frametype; *data: array [ 1..260 ] of integer; 'tracing: boolean; +cal, )chpos, )level, (offset, (parnum, (parb# #begin &if level = 0 then )error('Tooo many pops'); &with stack [ level ] do )begin ,chpos := pos; ,offset := off; )eal, *temp: integer; ,ch: char; # procedure error(s: string); # #begin &writeln(chr(7)); &writeln(s); &unitclear(1); nd; &level := level - 1; #end {pop}; procedure skip(lch, rch: char); # #var .cnt: integer; & #begin &cnt := 1; &rep&readln; &exit(mouse); #end {error}; function num(ch: char): integer; # #begin &if ch in [ 'a' .. 'z' ] &then )num :=eat )getchar; )if ch = lch )then ,cnt := cnt + 1 )else ,if ch = rch then /cnt := cnt - 1; &until (chpos > progsize) or ( ord(ch) - ord('a') + 1 &else )if ch in [ 'A' .. 'Z' ] )then ,num := ord(ch) - ord('A') + 1 )else ,error('Not a Letter'); cnt = 0); #end {skip}; procedure load(var f: text); # #var -this, -last: char; *charnum: integer; & #begin &chpos :#end {num}; �������������������������������������������������������������������������������������������������������������������= 0; &level := 0; &offset := 0; &cal := 0; &for charnum := 1 to 26 do )definitions [ charnum ] := 0; &charnum := 0; &this function val(ch: char): integer; # #begin &val := ord(ch) - ord('0'); #end {val}; procedure getchar; # #begin &ch := ' '; &repeat )last := this; )read(f, this); )charnum := charnum + 1; )prog [ charnum ] := this; )if (this in [ 'a' .. �pos := chpos + 1; &ch := prog [ chpos ]; &if tracing then )write(ch); &if chpos = progsize &then )ch := '$' &else )if ch�pos > progsize then ,error('Fell off end of program'); #end {getchar}; procedure pushcal(datum: integer); # #begin &cal� := cal + 1; &if cal > nestmax then )error('Tooo many calls'); &calstack [ cal ] := datum; #end {pushcal}; function popc�al: integer; # #begin &if cal = 0 then )error('Tooo many returns'); &popcal := calstack [ cal ]; &cal := cal - 1; #end {p{[a=12, p=4, q=1]} program mouse(input, output); const &nestmax = 50; &progmax = 1000; # type &tagtype = (macro, param, looopcal}; procedure push(tagval: tagtype); # #begin &level := level + 1; &if level > nestmax then )error('Tooo many pushep); $frametype = record <tag: tagtype; <pos, <off: integer; 1end; # var *prog: array [ 1.. progmax ] of char; &progsize:s'); &with stack [ level ] do )begin ,tag := tagval; ,pos := chpos; ,off := offset; )end; #end {push}; procedure pop;�4�� )getchar; )if ch in [ 'a' .. 'z' ] then ,begin /s := concat(s, ' '); /s [ length(s) ] := ch; ,end; &until not (ch in [ 'a's [ num(ch) ]; ,offset := offset + 26; )end &else )skip('#', ';'); #end {call}; procedure print; # #begin &repeat ) .. 'z' ]); {$I-} &reset(infile, concat(s, '.text')); {$I+} &if ioresult <> 0 &then )write('?') &else )load(infile); #endgetchar; ����������������������������������������������������������������������������������������������������������������������� {xload}; procedure number; # #begin &temp := 0; &while ch in [ '0' .. '9' ] do )begin ,temp := temp * 10 + val(ch); )if ch = '!' )then ,writeln )else ,if ch <> '"' then /write(ch); &until ch = '"'; #end {print}; procedure readin; #,getchar; )end; &pushcal(temp); &chpos := chpos - 1; #end {number}; procedure divide; # #begin &temp := popcal; &if  #begin &read(temp); &pushcal(temp); #end {readin}; begin {mouse} #tracing := false; #load(input); #repeat &getchar;temp = 0 then )error('Division by zero'); &pushcal(popcal div temp); #end {divide}; procedure assign; # #begin &temp : &case ch of )' ', ']', '$':; )'0', '1', '2', '3', '4', '5', '6', '7', '8', '9': ,number; )'a', 'b', 'c', 'd', 'e', 'f', 'g= popcal; &data [ popcal ] := temp; #end {assign}; procedure uparrow; # #begin &if popcal <= 0 then )begin ,pop; ,sk', 'h', 'i', 'j', 'k', 'l', 'm', 'n', ,'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z': ,pushcal(num(ch) + offset);ip('(', ')'); ������������������������������������������������������������������������������������������������������������������ )'?': ,readin; )'!': ,write(popcal: 1); )'\': ,tracing := not tracing; )'+': ,pushcal(popcal + popcal); )'-': ,pushca)end; #end {uparrow}; procedure return; # #begin &pop; &skip('#', ';'); #end {return}; procedure parameter; # #l(- popcal + popcal); )'*': ,pushcal(popcal * popcal); )'/': ,divide; )'~': ,xload; )'.': ,pushcal(data [ popcal ]); )'begin &getchar; &parnum := num(ch); &push(param); &parbal := 1; &temp := level; &repeat )temp := temp - 1; )case stack [=': ,assign; )'"': ,print; )'[': ,if popcal <= 0 then /skip('[', ']'); )'(': ,push(loop); )'^': ,uparrow; )')': ,chp temp ].tag of ,macro: /parbal := parbal - 1; ,param: /parbal := parbal - 1; ,loop:; )end; &until parbal = 0; &chpos := os := stack [ level ].pos; �����������������������������������������������������������������������������������������������������'z' ]) and (last = '$') then ,definitions [ num(this) ] := charnum; &until eof(f) or (this = '$') and (last = '$'); &ch := ' stack [ temp ].pos; &offset := stack [ temp ].off; &repeat )getchar; )if ch = '#' then ,begin /skip('#', ';'); /getchar; '; �����������������������������������������������������������������������������������������������������������������������������,end; )if ch = ',' then ,parnum := parnum - 1; &until (parnum = 0) or (ch = ';'); &if ch = ';' then )pop; #end {parameter&progsize := charnum; #end {load}; procedure xload; # #var 0s: string; +infile: text; & #begin &s := ''; &repeat }; procedure call; # #begin &getchar; &if definition [ num(ch) ] > 0 &then )begin ,push(macro); ,chpos := definition�5�� )'#': ,call; )'@': ,return; )'%': ,parameter; )',', ';': ,pop; &end; #until ch = '$'; end {mouse}. �������������������������{ COM : TERAK communication program George Gonzalez 6-Jun-78 Loosely based on� a program by Brian Hanson. COM makes the TERAK act as an 'intelligent' terminal. Beyond th�e normal terminal duties, it can send and receive files with error detection and correction. See f�ile COM.DOC for further information. Modification History ------------ ------- � John Easton 78/07/06 'L' list cmd added George Gonzalez 5-Sep-78 ��A ����������������������������������������������������������������������������������/������������������������O��^� Added delete trailing blanks/nulls 'O' command. General code cleanup. File Overfl���B�����������������������������������������������������������������������������������������������������������������������ow handling. G.G. 4-May-79 Cleaned up code. Speeded up main loop. Improv�ed null character processing. G.G. 1-Jul-79 Added micros. Added init file. ��������������������� Added auto-port select. More code cleanup. Checksum error detection. } {[a=19, P=5, I=4, q=1]} � {$D3} { } program com(input, output);   {$I COM.INIT.TEXT }   {$I COM.UTIL.TEXT } procedure SaveChar( C : char )�6�� meString) { print s1, return Name in S }; $ $var 9I: integer; ( $begin { GetFileName } (Write(Bell, s1, ' file: '); (readif NotAtMargin then ,begin 0PutChar(Return); 0SendChar(RubOut); ,end; (SendChar(EndOfText); (Quiet(Delay); (InTextMode :=l(RawName); (if RawName = '' then ,Abort; (UpperIt(RawName); (I := pos('/', RawName); (if I > 0 (then ,S := copy(RawName, false; $end {ExitTextMode}; , ,procedure RemoveVolume( var Name : string ); ,var 0I : integer; ,begin 2if Length( Name  1, I - 1) (else ,S := RawName; (GlobString := S; (GlobSText := concat(S, TextSuffix); $end { GetFileName }; procedure) > 0 then 4if Name[1] = '*' then 7delete(Name, 1, 1); 2I := pos(':', Name); 2if I > 0 then 6delete(Name, 1, I); 2while po { save a char }; $ $begin { saveit } (ch := C; (if SavingText (then ,begin { staging } 0if BufferPointer < MaxBuf 0then OpenIn(var Fine: boolean) { open input file }; $ $var 6Name: NameString; ( $ $ $ $ ������������������������������������ 4begin 8BufferPointer := BufferPointer + 1; 8CharBuf [ BufferPointer ] := ch; 4end 0else 4begin 8SavingText := false; 8$procedure InOpen(S: NameString; var Okay: boolean) { open S }; ( (begin ,Close(Fil); {$I-} ,reset(Fil, S); {$I+} ,Okay :=CharBuf [ BufferPointer ] := Return; 8Message('!! Record Buffer full !!'); 4end; ,end { staging }; (if (ch <> Null) and (ch  ioresult = 0; (end {InOpen}; $ $ $ $ $ $begin {OpenIn} (GetFileName(ThisCommand, Name); (InOpen(GlobSText, Fine); (if<> LineFeed) then ,begin { prt } 0chh [ 1 ] := ch; 0UnitWrite(SysTerm, chh, 1, 0, 1); ,end { prt }; $end {SaveChar}; p not Fine then ,InOpen(GlobString, Fine); (if not Fine then ,begin 0Message3('Can''t find file ', GlobSText, '!!'); 0Abort;rocedure readl(var Line: string) { read a Line, check for escapes }; $ $ $ $ $ $procedure EraseChar; ( (begin ,if Line  ,end; $end {OpenIn}; procedure OutputChar(Listing: boolean) { output file of char }; $ $ $ $ $ $procedure puteol; <> '' then 0begin 4delete(Line, Length( Line ), 1); 4Write(BackSpace, ' ', BackSpace); 0end; (end {EraseChar}; $ $ $ ���( (const 7rubmax = 3; , (var 7Rubouts: integer; , (begin ,PutChar(Return); ,ColumnPosition := 0; ,if Listing then 0S$ $ $begin {readl} (Line := ''; (get(Keyboard); (while not eoln(Keyboard) do ,begin 0if Keyboard ^ = Escape 0then 4AboendChar(LineFeed); ,for Rubouts := 1 to RubMax do 0SendChar(RubOut); ,Twiddle; (end {puteol}; $ $ $ $ $ $begin {Outputrt 0else 4if Keyboard ^ = Rubout 4then 8while Line <> '' do <EraseChar 4else 8if Keyboard ^ = BackSpace 8then <EraseChaChar} (while not eof(Fil) do ,begin { OutputChar } 0if eoln(Fil) 0then 4puteol 0else 4begin 8if Fil ^ = Tab 8then <repr 8else <if Length(Line) < LineSize then @begin DLine := concat(Line, ' '); DLine [ Length(Line) ] := Keyboard ^; DWrite(Leat @PutChar(' ') <until ColumnPosition mod 8 = 0 8else <PutChar(Fil ^); 4end; 0get(Fil); ,end { OutputChar }; ����������ine [ Length(Line) ]); @end; 0get(Keyboard); ,end; (WriteLn; $end {readl}; procedure GetFileName(s1: string; var S: Na(if ColumnPosition <> 0 then ,PutEOL; $end {OutputChar}; procedure ExitTextMode { NotAtMargin : Boolean }; $ $begin (�7�� Send( LastCom ); 0end ,else 0Message3('File ', HostFileName, ' is now your primary file.'); (end {FinalCommands}; $ $ $ ,then 0begin { present } 4err := yesNo( 4 concat( GlobSText, ' already exists, replace it?') ); 4Prompt := 'Okay then, what$ $ $begin { SendFile } (ThisCommand := 'Send'; (OpenIn(Okay); (HostFileName := GlobString; (RemoveVolume( HostFileName ); shall we call this'; 0end { present }; (until err; $ f := fn; $end {AskForNames}; procedure DumpBuffer ( Dotty : bo (FunnyName; (if Okay (then ,begin 0WriteLn('Final NOS Control Statement: ( Type RETURN for none )'); 0Readl( LastCom ); olean ) { Send characters in buffer }; $ $var 4Spaces, 6Base, 5Lines, .LastNonBlank, 9I, 9K: integer; ( $ $ $ $ $p0SendWait( 'BATCH' ); 0SendWait(concat('NEW,', HostFileName)); 0Send('TEXT'); 0InTextMode := true; 0Quiet(Delay); 0reset(Firocedure LeadingSpaces { output compressed leading spaces }; ( (begin ,Spaces := 0; ,while CharBuf [ I ] in NullSet do 0begl); 0ColumnPosition := 0; 0InitKbdRead; 0OutputChar(false); 0Close(Fil); 0FinalCommands; 0UnitClear(Console); ,end ������in 4if CharBuf [ I ] = ' ' then 8Spaces := Spaces + 1; 4I := I + 1; 0end; (end {LeadingSpaces}; $ $begin { DumpBuffer } $end { SendFile }; procedure ListFile { List file raw to other system }; $ $var 6Okay: boolean; ( $begin (ThisComman(I := 1; (Lines := 0; (CharBuf [ BufferPointer ] := Return; (while I < BufferPointer do ,begin { outline } 0LeadingSpaces; s('.', Name) > 0 do 5delete(Name, pos('.', Name), 1); ,end; / procedure SendFile { Send a text file to other system }; $d := 'List'; (OpenIn(Okay); (if Okay then ,begin 0ColumnPosition := 0; 0InitKbdRead; 0OutputChar(true); 0Close(Fil); 0Me $var 9I: integer; 2LastCom: string; .HostFileName: NameString; 6Okay, 5Funny: boolean; ( $ $ $ $ $procedure FunnyNassage3('Listing of ', GlobSText, ' is complete.'); ,end; $end {ListFile}; "function YesNo{ S : string ) : boolean }; "varme { check for invalid NOS file Name }; (var -I : integer; ( (begin ,Funny := false; ,for I := 1 to Length(HostFileName) d (Yes : boolean; "begin (Write(S); (get(KeyBoard); (Yes := KeyBoard^ in ['Y', 'y']; " if Yes then +WriteLn('Yes') (o 0Funny := Funny or not (HostFileName [ I ] in [ 'A' .. 'Z', '0' 3.. '9' ]); ,if Funny or (HostFileName = '') then ���������else +WriteLn('No!'); " YesNo := Yes; "end; "  procedure AskForNames(var f: NameString) { ask for file names, check0GetFileName('To Host', HostFileName); ,if Length(HostFileName) > 7 then 0HostFileName := copy(HostFileName, 1, 7); ( if  for dupl icates }; $ $var 7err: boolean; 8fn: NameString; 9C: char; ( $begin (repeat ,GetFileName(Prompt, fn); ,if HHostFileName = '' then /HostFileName := 'NoName'; (end {FunnyName}; $ $ $ $ $ $procedure FinalCommands { final commands ostFile = '' then 0HostFile := RawName; ,RemoveVolume( HostFile ); ,if pos(':', fn ) <> Length( fn ) then ,begin 2Close(Fil}; ( (begin ,ExitTextMode(ColumnPosition <> 0); ,Send('PACK'); ( if LastCom <> '' then 0begin 6Await( PromptChar ); 6); 2{$I-} 2reset(Fil, GlobSText); 2{$I+} 2err := ioresult <> 0; 2Close(Fil); ,end ,else 2err := true; ,if not err ������8�� se + 3); 4end; 4 1if I < BufferPointer then 5WriteLn(Fil); 1if Dotty then 1begin 8if Lines mod 50 = 0 then :begin =Writnge; 4end; ,end; $end {ComputeCheckSum}; procedure GetStuff { get a file from host }; $ $var 6Okay: boolean; ��������eLn; =Write('Writing to file', OutFileName); :end; 8Write('.'); 1end; 1 1Lines := Lines + 1; 1DumpLines := DumpLines + 1;5Tries, 1BeginLine, 2LocalSum, 3HostSum: integer; 4Digit1, 4Digit2, 4Digit3, 5Endch: char; ( $ $ $ $ $Function Num 1I := I + 1; .end { out����line }; $end {DumpBuffer}; procedure FlushBuf { Manually write out buffer }; $ $var 6Size(C: char): integer; ( (begin ,Num := Ord(C) - Ord('0'); (end {Num}; $   procedure ErrorSummary;  var (I: integer;  : integer; 9S: NameString; ( $begin { FlushBuf } (if BufferPointer > 0 (then ,begin { wtf } 0Size := BufferPointer; 0Thi (function min( I, J : integer ) : integer; (begin 0if I < J then 3min := I 0else 3min := J; (end; ( (  begin (if ErrsCommand := 'Write'; 0Prompt := ' Write Record Buffer to'; 0AskForNames(GlobSText); 0NewOpen(GlobSText); 0DumpLines := 0; 0orCount = 0 then +Message('No transmission errors.') (else (begin 0WriteLn('Unrecovered errors!!:'); 0for I := 1 to min( ErDumpBuffer( pos(':', GlobString) <> Length( GlobString) ); 0Close(Fil, lock); 0Writeln; ��������������������������������������rorCount, ErrorMax ) do 3with ErrorCache[ I ] do 8WriteLn( 'Error detected between line #', Starting, @' and line #', Ending)0WriteLn(Bell, '{ ', DumpLines, ' lines written. }'); ,end { wtf } (else ,Message('Nothing in the buffer!!'); $end { flush ;  if ErrorCount > ErrorMax then 0WriteLn('Plus ', ErrorCount - ErrorMax, 8' more errors later in the file.')CharBuf }; procedure NextFile { open next output file }; $ $var 9Z: string; ( $begin (CharCount := 0; (if Suffix = '; (end;  end;  $ $ $ $begin {GetStuff} (Tries := 0; (repeat ,SavingText := true; ,BufferPointer := 0; ,Await(Start?' (then ,Suffix := 'A' (else ,Suffix := succ(Suffix); (Close(Fil, lock); (Z := '.Z.TEXT'; (Z [ 2 ] := Suffix; (NewOpen(OfText); ,Await(LineFeed); ,repeat 0repeat 4Twiddle; 0until Ready in IoPort ^.InputCSR; �����������������������������������0Base := I { delete trailing junk }; 0LastNonBlank := I - 1; 0while CharBuf [ I ] <> Return do 4begin 8if CharBuf [ I ] in concat(GlobString, Z)); $end {NextFile}; Procedure ComputeCheckSum(var Sum: integer); $ $var 8ch: char; 2CountSet: SetOkaySet then <LastNonBlank := I; 8I := I + 1; 4end; 0if LastNonBlank >= Base 0then 4begin 8if Spaces > 2 ���������������� of char; 9I, 9J: integer; ( $begin (Sum := 0; (CountSet := [ LowChar .. HighChar ] - [ Rubout, Null ]; (for I := 1 to Bu then ;Write(Fil, SpaceEater, chr(32 + Spaces)) 8else ;for K := 1 to Spaces do ?Write(Fil, ' '); 8fofferPointer - 1 do ,begin 0ch := CharBuf [ I ]; 0If ch in CountSet 0then 4begin 8If ch = Return then <begin @J := I - 1;r K := Base to LastNonBlank do <Write(Fil, Charbuf[ K ]); 8if OverflowCheck then <CharCount := CharCount + (LastNonBlank - Ba @while CharBuf [ J ] = ' ' do Dbegin HJ := J - 1; HSum := Sum - Ord(' '); Dend; <end; 8Sum := (Sum + Ord(ch)) mod CharRa�9�� Digit3 := Modem; ,HostSum := Num(Digit1) * 64 + Num(Digit2) * 8 + Num(Digit3); ,ComputeCheckSum(LocalSum); ,Okay := (LocalSume := ''; (AskForNames(getname); (NewOpen(getname); (SendStuff( TransferCommand, HostFile ); (InitKbdRead; (CharCount := 0;  = HostSum) or (Tries > MaxTries); ,if Okay ,then 0begin 4BufferPointer := BufferPointer - 1; 4if CharCount > EditMax then (ErrorCount := 0; (DumpLines := 1; (Suffix := '?'; (Await(StartOfText); (if Modem = StartOfText (then ,GetStuff; ��������8NextFile; 4BeginLine := DumpLines; 4DumpBuffer( True ); 4if Tries > MaxTries then 7begin =ErrorCount := ErrorCount + 1; (UnitClear(Console); $end {Getter}; procedure Toggle(Name: string; var Switch: boolean) { Flip switch and notify }; $ $=if ErrorCount <= ErrorMax then @with ErrorCache[ ErrorCount ] do @begin EStarting := BeginLine; EEnding := DumpLines; @ebegin (Switch := not Switch; (if Switch (then ,Message3(Name, ' turned ON', '') (else ,Message3(Name, ' turned OFF', ''); nd; 4 end; 4Send('A'); 4Tries := 0; 0end ,else 0begin { err } 4Tries := Tries + 1; 4Send('N'); 4Message('Transmissio$end {Toggle}; procedure ModemWarning { Warn of change in modem status }; $ $begin (ModemStatus := CarrierDetect in IoPn error-- retrying.'); 0end { err }; (until Okay and (Endch = EndOfText); (Await(PromptChar); (Close(Fil, lock); (Message3(ort ^.OutputCSR; (if ModemStatus (then ,Message('Carrier detected') (else ,Message('Carrier lost'); $end {ModemWarning}; 'File ', GlobSText, ' Saved'); (if Suffix <> '?' (then ,begin { ovflo } 0Message('Overflow text written to files:'); ������� procedure ClearBuffer { Clear saved text buffer }; $ $begin (if BufferPointer > 0 (then ,begin 1if YesNo('Do you reall0for ch := 'A' to Suffix do 4WriteLn(GlobString, '.', ch, TextSuffix); ,end { ovflo }; (ErrorSummary; $ Savingtext := fay want to clear the Record Buffer?') then 1begin 5BufferPointer := 0; 5Message('Record Buffer Cleared') 1end ,end (else ,lse; $ BufferPointer := 0; $end {GetStuff}; procedure Getter { get file from host }; $ $var 3getname: NameString; (Message('Record Buffer already empty'); $end {ClearBuffer};  procedure ChangeChar;  begin (Write('Change Command Prefix c $ $procedure SendStuff( Out, Filler : string ); $var $ P : integer; $begin (P := pos('~', Out); (While P > 0 do ( beharacter to:'); (Get(Keyboard); (CommandChar := Keyboard^; (WriteLn; (Write('{ Command prefix character changed to '); �����gin +Delete( Out, P, 1) ; +insert( Filler, Out, P); +P := pos('~', Out); ( end; ( (repeat -P := pos( '|', Out ); -if P =(ControlOut( CommandChar );  Writeln(' }');  end;       procedure ReadMicro { var F : text ; var S : Longs 0 then /begin 5Send( Out ); 5P := length( out ); /end -else 0Send( copy(Out, 1, P-1) ); - -delete(Out, 1, P); -if Out tring ; 6Self : char ; EchoChar, SpecialFile : boolean } { Read Micro def. }; $label *1; $var (LastChar: char; $ $ $proc0SaveChar( chr(IoPort ^.InData mod CharRange) ); ,until ch in QuitSet; ,EndCh := ch; ,Digit1 := Modem; ,Digit2 := Modem; ,<> '' then 0Await( PromptChar ); (until Out = ''; $end; $ $ $ $begin (ThisCommand := 'Get'; (Prompt := 'Get'; (HostFil�:�� nfo file'); (OutBoolean(HalfDuplex, 'D'); (OutBoolean(OverflowCheck, 'O'); (WriteLn( Info, 'X:', TransferCommand ); (Write( Low then BTicks := Ticks + 1; : OldLow := Low; :until Ticks > BreakTime ; :OutputCSR := OutputCSR - [ BreakBit ]; Info, 'C:'); (OutCtrl(CommandChar); (WriteLn( Info ); (for C := LowChar to HighChar do ,if Micro [ C ] <> nil then 0begin  end 0else 0if Micro [ C ] <> nil 0then 4for I := 1 to Length(Micro [ C ] ^) do 8PressedKey(Micro [ C ] ^ [ Iedure GetChar( var F : text ); $begin )get(F); )if SpecialFile then )begin -if F^ = '^' then /begin 3get(F); 3if F^ <> '4Write(Info, 'M:'); 4OutCtrl(C); 4Write(Info, '='); 5for I := 1 to Length( Micro [ C ] ^ ) do �������������������������������^' then 5F^ := Chr( Ord(F^) - Ord('@') ); /end; )end; %end; % % % $begin (S := ''; (LastChar := Null; (GetChar(F); (7OutCtrl( Micro [ C ] ^ [ I ] ); 5OutCtrl(CommandChar); 5OutCtrl(CommandChar); ( WriteLn( Info ); ( end;while (F ^ <> CommandChar) or (Lastchar <> CommandChar) do ,begin 0if (S <> '') and (F ^ = Self) then 6Message('Micro cannot  (close(Info, Lock); (Message('Info file updated.'); $end {UpdateInfo}; procedure InputCommand { C : char } { Process a include itself!') 2else 2begin 0if Length(S) < LineSize 0then 4begin 8S := concat(S, ' '); 8if EoLn(F) then <F ^ := Retuuser command }; $ $begin { InputCommand } (case C of ,'C': 0ClearBuffer; ,'D': 0Toggle('Half Duplex', HalfDuplex); ,'G':rn; 8S [ Length(S) ] := F ^; 4 LastChar := F^; 4end 0else 4begin :Message('Micro is full!!'); 0 goto 1; 4end 0Getter; ,'H': 0Help; ,'L': 0ListFile { jte }; ,'M': 0Micros; ,'O': 0Toggle('Overflow checking', OverflowCheck); ,'P'; 0if EchoChar then 4ControlOut( F^ ); 0end; 0GetChar(F); ,end; $ if Length( S ) > 0 then ���������������������������: 0ChangeChar; ,'Q': 0Quit := true; ,'R': 0Toggle('Saving text', SavingText); ,'S': 0SendFile; ,'U': 0UpdateInfo; ,'W'-Delete(S, Length(S), 1); $1: $end {ReadMicro}; procedure UpdateInfo { Write info file }; $ $var 9I: integer; 9C: ch: 0FlushBuf; (end; $end { InputCommand }; Procedure Key; $forward; procedure PressedKey(C: char) { Process a user ar; 6Info: text; ( $ $ $ $ $procedure OutBoolean(Flag: boolean; C: char) { Output boolean }; ( (begin ,Write(Info, C, or Micro keypress }; $ ( (procedure ProcessCommand; (var -ComChar: char; (begin ,NeedCommand := false; ,ComChar := Uppe':'); ,if Flag ,then 0WriteLn(Info, '+') ,else 0WriteLn(Info, '-'); (end {OutBoolean}; $ $ $ $procedure OutCtrl( C : crCase( C ); ,if ComChar in CommandSet ,then 0InputCommand(ComChar) ,else 0Pressedkey(ComChar) (end ; ( ������������������har ); $begin )if C = '^' then ,Write(Info, '^^') )else )if Ord(C) in [0..31, 127] then ,Write(Info, '^', Chr( Ord(C) + Or,procedure HandleKey; ,var 9I, High, Low, OldLow, Ticks: integer; ,begin 0if Ord( C ) = BreakCode then 3with IoPort^ do 4d('@') ) ) )else ,Write(Info, C); $end; $ $ $ $begin {UpdateInfo} (ReWrite(Info, InitName); (WriteLn(Info, '*** COM ibegin :OutputCSR := OutputCSR + [ BreakBit ]; :Ticks := 0; :OldLow := -1; :repeat @Time( High, Low ); : if Low <> Old�;�� �tatmtBeginning, 2Mark1, 2Mark2, 2Mark3, 2Mark4: Placemarks; 4Ind, 'BlksOnCurrntLine, $BlksAddedByThisStmt: Integer; -Suc�cessful: Boolean; ) & & & &procedure Bunch(Beginning, Breakpt, Ending: Placemarks; StatmtSeparation: 'OptionSize); ) )va�r 9i: integer; , )begin ,if BunchWanted or IfThenBunchNeeded ,then /begin 2StatmtSeparation := Max(1, StatmtSeparation); �2BlksOnCurrntLine := BlksOnCurrntLine + StatmtSeparation - 1; 2With UnWritten [ Beginning.BuffPointer ] do 5if ChIsEndLine 5�����������������������������������������������������������������������������������������������������������������������O��^�then 8Ind := IndentAfterEOL 5else 8Ind := 0; 2Successful := ((Ending.CharCount - Beginning.CharCount + 3BlksOnCurrntLine +  ]) 0else 4begin :SendChar(C); :if HalfDuplex then >SaveChar(C); :if Ready in IoPort^.InputCSR then >MoveChar; , ���3B7�����������������������������������������������������������������������������������������������������������������������end; ,end; ( $begin { PressedKey } (PressLevel := PressLevel + 1; (if Presslevel > Nestmax then ,begin 0Message('Micros n�ested too deeply!'); 0InitKbdRead; 0Exit(Key); ,end; , (if NeedCommand then -ProcessCommand (else ,if C = CommandChar th�en 0NeedCommand := true )else ( HandleKey; (PressLevel := PressLevel - 1; $end {PressedKey}; ����������������������procedure Key { Process user key }; $ $begin (PressLevel := 0; (PressedKey(NextChar); (InitKbdRead; $end {Key}; proce�dure MainCom { Main loop }; $ $begin (InitkbdRead; (repeat ,if ModemStatus <> (CarrierDetect in IoPort ^.OutputCSR) then 0�ModemWarning; ,if not UnitBusy(Console) then 0Key; ,if Ready in IoPort ^.InputCSR then 5SaveChar( chr(IoPort ^.InData mod Ch�arRange) ); (until Quit; $end {MainCom}; begin { com } $Initialize; $Help; $MainCom; end { com }. ������������������� # #procedure DoStatement(var AddedBlanks: Width; StatmtSymbol: CommentText; $StmtSymLength: Width); & &var 6I: Width; (S�<�� tatmtSymbol; ,Length := StmtSymLength; ,SymbolName := PeriodSymbol; ,LastSymbol := PeriodSymbol; ,WriteSymbol; ,Symbol [ 1 -PeriodSymbol ]); ,if Successful ,then /begin 2if EndList = UntilSymbol 2then 5Mark4.CharCount := StatmtSeparation 2else] := '}'; ,Length := 1; ,WriteSymbol; ,SymbolName := SavedSymbolName; ,Length := SavedLength; ,Symbol := SavedChars; )end  5Mark4.CharCount := SymbolGap; 2Bunch(StatmtBeginning, Mark1, Place, Mark4.CharCount); /end; ,if not (Successful and BunchW{ WriteComment }; & & & & &procedure DoStmtList(EndList: Symbols); ) )var -BlksAfterPrt2: Width; 1AtProcEnd: Boolean; anted) ,then /if (EndList = EndSymbol) and (LastSymbol = EndSymbol) then 2if AtProcEnd and ProcNamesWanted 2then 5WriteComm, ) ) ) )procedure DoNonEnd; , ,begin /while SymbolName <> EndList do 2begin 5WriteRead; 5if SymbolName <> EndList 5tent 2else 5if EndCommentsWanted then 8WriteComment; )end { DoStmtList }; & & & & &procedure IfStat; ) )begin ,Statmthen 8begin ;Mark3 := NextPlace; ;DoStatement(AddedBlanks, StatmtSymbol, StmtSymLength <); ����������������������������������Symbol := Symbol; ,StmtSymLength := Length; ,CopySymbol([ ThenSymbol ]); ,StartNewLineAndIndent; ,Mark1 := Place; ,WriteRea;BlksOnCurrntLine := AddedBlanks + BlksAfterPrt2; ;BlksAddedByThisStmt := BlksAddedByThisStmt + <AddedBlanks; ;Bunch(Mark2, d; ,Mark2 := NextPlace; ,DoStatement(AddedBlanks, StatmtSymbol, StmtSymLength); ,BlksOnCurrntLine := AddedBlanks; ,BlksAddedMark3, Place, StatmtSeparation); ;if not Successful ;then >begin ABlksAfterPrt2 := AddedBlanks; AMark2 := Mark3; >end ;elByThisStmt := AddedBlanks; ,Bunch(Mark1, Mark2, Place, SymbolGap); ,if Successful ,then /Bunch(StatmtBeginning, Mark1, Placese >BlksAfterPrt2 := BlksOnCurrntLine; 8end; 2end {while}; ,end { DoNonEnd }; ) ) ) ) )begin { DoStmtList } ,AtProcEnd, StatmtSeparation) ,else /IfThenBunchNeeded := True; ,if SymbolName = ElseSymbol ,then /begin 2StatmtSymbol := Symbol; ��Ind) < WriteRightCol) and (Place. 3CharCount - Beginning.CharCount < BufferSize); 2if Successful 2then 5begin 8BlksAddedByT := AtProcBeginning; ,WriteRead; ,if SymbolName <> EndList ,then /begin 2if ProcNamesWanted and AtProcBeginning and 3LasthisStmt := BlksAddedByThisStmt + 9StatmtSeparation - 1; 8With UnWritten [ Breakpt.BuffPointer ] do ;if ChIsEndLine then �����ProgPartWasBody and (LastSymbol = BeginSymbol) 2then 5WriteComment; 2Mark1 := NextPlace; 2Mark2 := Mark1; 2AtProcBeginning >IndentAfterEOL := - StatmtSeparation; 5end; /end; )end { Bunch }; & & & & &procedure WriteComment; ) )var /SavedLen:= False; 2DoStatement(AddedBlanks, StatmtSymbol, StmtSymLength); 2BlksAfterPrt2 := AddedBlanks; 2BlksAddedByThisStmt := Blksgth: Width; +SavedSymbolName: Symbols; 0SavedChars: SymbolString; , )begin ,SavedSymbolName := SymbolName; ,SavedChars := AddedByThisStmt + AddedBlanks; 2DoNonEnd; /end; ,BlksOnCurrntLine := BlksAddedByThisStmt; ,Bunch(StatmtBeginning, Mark1, PlaSymbol; ,SavedLength := Length; ,SymbolName := OtherSymbol; ,Symbol [ 1 ] := '{'; ,Length := 1; ,WriteSymbol; ,Symbol := Sce, SymbolGap); ,StartNewLineAndIndent; ,Mark1 := Place; ,CopySymbol([ Semicolon, UntilSymbol, EndSymbol, ElseSymbol, ��������=�� AddedByThisStmt + AddedBlanks; 2Bunch(Mark3, Mark4, Place, SymbolGap); 2BlksOnCurrntLine := BlksAddedByThisStmt; 2if Successfd; ,Mark1 := NextPlace; ,DoStatement(AddedBlanks, StatmtSymbol, StmtSymLength); ����������������������������������������������ul then 5Bunch(StatmtBeginning, Mark3, Place, StatmtSeparation); /end ,else /if (Place.CharCount - StatmtBeginning.CharCount,BlksOnCurrntLine := BlksOnCurrntLine + AddedBlanks; ,BlksAddedByThisStmt := BlksAddedByThisStmt + AddedBlanks; ,Bunch(Statmt) < BufferSize /then 2begin 5BunchWanted := not BunchWanted; 5BlksOnCurrntLine := 0; 5Bunch(StatmtBeginning, Mark1, Mark2, Beginning, Mark1, Place, SymbolGap); )end { DoForStatement }; & & & & &begin { DoStatement } )BlksOnCurrntLine := 0; )SuSymbolGap); 5BunchWanted := not BunchWanted; 2end; ,IfThenBunchNeeded := False; )end { IfStatement }; & & & & &Procedurccessful := False; )BlksAddedByThisStmt := 0; )ChangeMarginTo(ActualLeftMargin + IndentIndex); )StartNewLineAndIndent; )State DoCaseStatement; ) )begin ,CopySymbol([ OfSymbol ]); ,WriteRead; ,ChangeMarginTo(ActualLeftMargin + IndentIndex); ,whilemtBeginning := Place; )if SymbolIsNumber )then ,begin /with UnWritten [ Place.BuffPointer ] do 2IndentAfterEOL := Max(0, In SymbolName <> EndSymbol do /begin 2StartNewLineAndIndent; 2Mark1 := Place; 2StatmtSymbol := Symbol; �����������������������dentAfterEOL - 1 - Length - 3SymbolGap); /WriteRead {Write Label}; /WriteRead {Write Colon}; ,end; )case StatementTypeOf [ 2StmtSymLength := Length; 2CopySymbol([ ColonSymbol ]); 2WriteRead; 2if not (SymbolName in [ Semicolon, EndSymbol ]) 2then SymbolName ] of ,ForWithWhileStatement: /DoForStatement; ,RepeatStatement: /DoStmtList(UntilSymbol); ,IfStatement: /IfStat5begin 8Mark2 := NextPlace; 8DoStatement(AddedBlanks, StatmtSymbol, StmtSymLength); 8BlksOnCurrntLine := AddedBlanks; 8Blks; ,CaseStatement: /DoCaseStatement; ,OtherStatement: /begin 2while not (SymbolName in [ Semicolon, UntilSymbol, EndSymbol, AddedByThisStmt := BlksAddedByThisStmt + 9AddedBlanks; 8Bunch(Mark1, Mark2, Place, SymbolGap); 5end; 2if SymbolName = Semico3ElseSymbol ]) do 5WriteRead; /end; ,CompoundStatement: /DoStmtList(EndSymbol) )end {case}; ������������������������������lon then 5WriteRead; /end; ,ChangeMarginTo(ActualLeftMargin - IndentIndex); ,StartNewLineAndIndent; ,WriteRead; ,if EndCom)AddedBlanks := BlksAddedByThisStmt; )ChangeMarginTo(ActualLeftMargin - IndentIndex); &end { DoStatement }; # # # # #begmentsWanted and (LastSymbol = EndSymbol) ,then /begin 2StatmtSymbol [ 1 ] := 'C'; 2StatmtSymbol [ 2 ] := 'A'; 2StatmtSymbolin { DoBlock } &LastProgPartWasBody := LastProgPartWasBody and (SymbolName = BeginSymbol) $; &if SymbolName = LabelSymbol the2StmtSymLength := Length; 2IfThenBunchNeeded := False; 2StartNewLineAndIndent; 2Mark3 := Place; 2WriteRead; 2Mark4 := Next [ 3 ] := 'S'; 2StatmtSymbol [ 4 ] := 'E'; 2StmtSymLength := 4; 2WriteComment; /end; )end { CaseStatement }; & & & & &Place; 2DoStatement(AddedBlanks, StatmtSymbol, StmtSymLength); 2BlksOnCurrntLine := AddedBlanks; 2BlksAddedByThisStmt := BlksProcedure DoForStatement; ) )begin ,StatmtSymbol := Symbol; ,StmtSymLength := Length; ,CopySymbol([ DoSymbol ]); ,WriteRea�>�� bol, TypeSymbol, VarSymbol, ProcSymbol, FuncSymbol, 'SegSymbol, BeginSymbol ]; &EndConst := EndLabel - [ ConstSymbol ]; &EndT Pascal program.'); )end &else )begin ,WriteLn('Program ', InputFileName, ' Spruced into file ', -OutputFileName); ,Close(n )DoDeclarationUntil(EndLabel); &if SymbolName = ConstSymbol then )DoDeclarationUntil(EndConst); &if SymbolName = TypeSymboype := EndConst - [ TypeSymbol ]; &EndVar := EndType - [ VarSymbol ]; { Initialize column data: } &WriteColumn := 0; ��������l then )DoDeclarationUntil(EndType); &if SymbolName = VarSymbol then )DoDeclarationUntil(EndVar); &while SymbolName in [ Fun&LeftMargin := 0; &ActualLeftMargin := 0; &OutputCol := 1; &ReadLeftCol := 1; &ReadRightCol := MaxReadRightCol; &WriteLeftcSymbol, ProcSymbol, SegSymbol ] do )DoProcedures; &if SymbolName = BeginSymbol &then )begin ,if LastProgPartWasBody then Col := 1; &WriteRightCol := MaxWriteRightCol; &Place.BuffPointer := 1; &Place.CharCount := 1; &LineNumber := 0; &Increment /for I := 2 to ProcSeparation do 2StartNewLineAndIndent; ,IfThenBunchNeeded := False; ,AtProcBeginning := True; ,ChangeMargi:= 0; { Initialize boolean parameters: } &PackerIsOff := True; &BunchWanted := False; &DisplayIsOn := True; &ProcNamesWantenTo(ActualLeftMargin - IndentIndex); ,DoStatement(I, BlockName, BlockNmLength) { I IS DUMMY PARAM }; ,LastProgPartWasBody := Td := True; &EndCommentsWanted := False; &NoFormatting := False; { Initialize numeric parameters: } &IndentIndex := 3; &Longrue; ,ChangeMarginTo(ActualLeftMargin + IndentIndex); )end {if} &else )WriteRead {Write Forward}; &Place.CharCount := 1; ��LineIndent := 3; &ProcSeparation := 2; &SymbolGap := 1; &StatmtSeparation := 3; &DeclarAlignment := 0; &BracketGap := 0; { #end { DoBlock }; procedure Initialize; # #var 3I: Width; & #begin { Constants: } &Digits := [ '0' .. '9' ]; &LetteInitialize input context data: } &ReadColumn := 1; &ChIsEOL := False; &NextChIsEOL := False; &for I := 0 to BufferSize do rsAndDigits := [ 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', ''K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V',)Symbol [ I ] := ' '; &LastSymbol := PeriodSymbol; &LastProgPartWasBody := False; #end { Initialize }; procedure Formatit 'W', 'X', ''Y', 'Z', 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', ''m', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u'; # #begin { F O R M A T T H E P R O G R A M ��������������������������������������, 'v', 'w', 'x', 'y', 'z' ] + 'Digits; &AlphaSymbols := [ ProgSymbol, BeginSymbol, EndSymbol, ConstSymbol, 'TypeSymbol, Recor - - - - - - - - - - - - - - - - } &StartNewLineAndIndent; &WriteRead; &Main := SymbdSymbol, CaseSymbol, IfSymbol, ThenSymbol, ElseSymbol, 'DoSymbol, OfSymbol, ForSymbol, WithSymbol, WhileSymbol, RepeatSymbol, ol; &MainNmLength := Length; &CopySymbol([ Semicolon ]); &WriteRead; &StartNewLineAndIndent; &DoBlock(Main, MainNmLength); 'UntilSymbol, Identifier, VarSymbol, ProcSymbol, FuncSymbol, SegSymbol, 'LabelSymbol, AlphaOperator ]; &EndLabel := [ ConstSym&WriteA('.'); &FlushUnwrittenBuffer; &if SymbolName <> PeriodSymbol &then )begin ,WriteLn; ,WriteLn(' *** Errors found in�?�� �ecification [ 1 ]; /'L': 2LongLineIndent := Specification [ 1 ]; /'P': 2ProcSeparation := Specification [ 1 ]; /'S': 2Stat�mtSeparation := Specification [ 1 ] ,end {case}; &end { SingleParameters }; # # # # #procedure DoubleParameters; & &beg�in )ReadIn(2, Specification); )if Specification [ 2 ] <> Invalid )then ,case FormatOption of /'W': 2if (Specification [ 1 & procedure DoFormatterDirectives; # #const ,Invalid = - 1; & #type )ParamCount = 1 .. 2; -Params = array [ ParamCount] > 0) and (Specification [ 2 ] < 3BufferSize - 2) and (Specification [ 2 ] - Specification [ 1 3] > 8) 2then 5begin 8WriteOut, Lock); )end; #end { FormatIt }; begin { MainProgram } #ConstantsInitialization; #Initialize; #OpenIn; #OpenOut;  ] of Integer; & #var 'Specification: Params; +UpperChar, (FormatOption: Char; )PrevDisplay, $PrevNoFormatting: Boolean; #if EOF(Inp) #then &WriteLn(' *** Empty file.') #else &begin )ReadACharacter; )ReadSymbol; )if SymbolName <> ProgSymbol *EndDirectv: CharSet; & # # # #procedure ReadIn(N: ParamCount; var Specification: Params); &var 6I: ParamCount; ) &be)then ,WriteLn(' *** "PROGRAM" was expected.') )else ,FormatIt; &end; end { MainProgram }.  ������������������������������gin )for I := 1 to N do ,begin /while not (Character in (Digits + EndDirectv)) do 2CopyACharacter; /Specification [ I ] := �0; /if not (Character in EndDirectv) /then 2repeat 5Specification [ I ] := 10 * Specification [ I ] + Ord( 6Character) - Or�����������������������������������������������������������������������������������������������������������������������O��^�d('0'); 5CopyACharacter; 2until not (Character in Digits) /else 2Specification [ I ] := Invalid; ,end; &end { ReadIn }; #���/C$����������������������������������������������������������������������������������������������������������������������� # # # #procedure SingleParameters; & &begin )ReadIn(1, Specification); )if (Specification [ 1 ] < WriteRightCol - Write�LeftCol - 9) or ( *FormatOption = 'P') )then ,case FormatOption of /'A': 2DeclarAlignment := Specification [ 1 ]; /'E': ���2if Specification [ 1 ] < 4 then 5begin 8ProcNamesWanted := Specification [ 1 ] > 1; 8EndCommentsWanted := Odd(Specificaton �[ 1 ]); 5end; /'G': 2SymbolGap := Specification [ 1 ]; /'Q': 2BracketGap := Specification [ 1 ]; /'I': 2IndentIndex := Sp�@�� e FormatOption of /'B': 2if DisplayIsOn then 5BunchWanted := Character = '+'; /'C': 2PackerIsOff := Character = '-'; /'D':n )CopyACharacter; #end { DoFormatterDirectives }; procedure ReadSymbol; # #const 0Tab = 9; )ReadNextCh = True; %Dont 2begin 5PrevDisplay := DisplayIsOn; 5DisplayIsOn := Character = '+'; 5if PrevDisplay and not DisplayIsOn 5then 8begin ;WReadNextCh = False; & #var *TestSymbol: Alfa; *CharNumber: Width; 3I: Width; & # # # #procedure SkipComment( StopCharariteA('*'); ;WriteA(')'); ;SavedBunch := BunchWanted; ;BunchWanted := False; 8end 5else 8if not PrevDisplay and DisplayIsOcter: char ); & &begin )if StopCharacter = '}' )then ,while Character <> StopCharacter do /ReadACharacter )else ,repeat n then ;begin >StartNewLineAndIndent; >WriteA('('); >WriteA('*'); >BunchWanted := SavedBunch; ;end; 2end { 'D': }; ������/while Character <> '*' do 2ReadACharacter; /ReadACharacter; ,until Character = ')'; )ReadACharacter; )LastSymbol := Comme/'F': 2begin 5PrevNoFormatting := NoFormatting; 5NoFormatting := Character = '-'; 5DisplayIsOn := not NoFormatting; 5if Prnt; )ReadSymbol; &end { SkipComment }; # # # # #procedure DoComment( StopCharacter: char ); & &var 6I: OptionSize; ) evNoFormatting and not NoFormatting then 8ReadACharacter; 5if not PrevNoFormatting and NoFormatting then 8WriteA('-'); 2end & & & &procedure CompilerDirectives; ) )begin ,repeat /CopyACharacter; ,until Character in [ '[', '*', '}' ] )end { Co{'F'}; ,end {case}; &end { BooleanParameters }; # # # # #begin { DoFormatterDirectives } &EndDirectv := [ '*', ']' ]; &mpilerDirectives }; & & & & &begin { DoComment } )if LastSymbol in [ Comment, Semicolon ] then ,begin �������������������LeftCol := Specification [ 1 ]; 8WriteRightCol := Specification [ 2 ]; 5end; /'R': 2if (Specification [ 1 ] > 0) and (Specifrepeat )UpperChar := UpperCase(Character); )if UpperChar in [ 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'I', 'L', 'N', *'P', 'Q', 'Rication [ 2 ] - 3Specification [ 1 ] > 8) 2then 5begin 8ReadLeftCol := Specification [ 1 ]; ��������������������������������', 'S', 'W' ] )then ,begin /FormatOption := UpperChar; /case FormatOption of 2'A', 'E', 'I', 'G', 'P', 'Q', 'L', 'S': 5Sin8ReadRightCol := Specification [ 2 ]; 5end; /'N': 2begin 5LineNumber := Specification [ 1 ]; 5Increment := Specification [gleParameters; 2'W', 'R', 'N': 5Doubleparameters; 2'B', 'C', 'D', 'F': 5Booleanparameters; /end {case}; ,end )else ,beg 2 ]; 5while not (Character in ([ '<' ] + EndDirectv)) and ( 6Character <> '>') do 8CopyACharacter; 5if Character = '>' thenin /CopyACharacter; /if (UpperChar in [ 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 0'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 8Increment := - Increment 2end {'N'} ,end {case}; &end { DoubleParameters }; # # # # #procedure BooleanParameters; &  'R', 'S', 'T', 'U', 'V' 0, 'W', 'X', 'Y', 'Z' ]) /then 2begin 5WriteLn; ���������������������������������������������������&begin )repeat ,CopyACharacter; )until Character in ([ '+', '-' ] + EndDirectv); )if Character in [ '+', '-' ] )then ,cas5WriteLn('*** Unknown Spruce Directive:', Character); 2end; ,end; &until Character in EndDirectv; &if (Character = ']') the�A�� = ')'; )CopyACharacter; )LastSymbol := Comment; )ReadSymbol; &end { DoComment }; # # # # #procedure CheckFor(SecondChar2until not (Character in Digits) ,end; )Length := CharNumber; )SymbolName := Identifier; &end { Number }; # # # # #beg: Char; TwoCharSymbol: Symbols; ReadAllowed: $Boolean); & &begin )if ReadAllowed then ,begin /Length := 1; /Symbol [ 1 ] in { ReadSymbol } &if (Character in [ 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', ''L', 'M', 'N', 'O', 'P', 'Q', 'R:= Character; /SymbolName := NameOf [ Character ]; /ReadACharacter; ,end; )if Character = SecondChar )then ,begin /Symbol', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', ''Z', 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'k', 'l', 'm', 'n', ''o', 'p', 'q', ' [ 2 ] := Character; /Length := 2; /SymbolName := TwoCharSymbol; /ReadACharacter; /if (not PackerIsOff) and (SymbolName = Cor', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z', '0' .. '9', '' ', '(', '.', ':', '''', '<', '>', '{' ]) &then )case Character of mment) then 2Length := 0 ,end; &end { CheckFor }; # # # # #procedure Letters; & &begin )CharNumber := 0; ������������,'{': /begin 2Length := 1; 2Symbol [ 1 ] := Character; 2SymbolName := Comment; 2ReadACharacter; 2if PackerIsOff 2then 5)SymbolIsNumber := False; )repeat ,CharNumber := CharNumber + 1; ,Symbol [ CharNumber ] := Character; ,ReadACharacter; )unDoComment('}') 2else 5SkipComment('}'); /end; ,'(': /begin 2CheckFor('*', Comment, ReadNextCh); 2if (SymbolName = Commenttil not (Character in LettersAndDigits); )Length := CharNumber; )TestSymbol := ' '; )for I := 1 to Min(Length, AlfaLe) and PackerIsOff 2then 5DoComment( Character ) 2else 5if SymbolName = Comment then 8SkipComment( Character ); /end; ,'A'ngth) do ,TestSymbol [ I ] := UpperCase(Symbol [ I ]); )PascalSymbol [ IdMax ] := TestSymbol; )I := 1; )while PascalSymbol [, 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', ������������������������������������������������������������������ I ] <> TestSymbol do ,I := I + 1; )SymbolName := PascSymbolName [ I ]; &end { Letter }; # # # # #procedure Numbers; & -'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', -'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'k', 'l', 'm',&begin )SymbolIsNumber := True; )CharNumber := 0; )repeat ,CharNumber := CharNumber + 1; ,Symbol [ CharNumber ] := Charact 'n', -'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z': /letters; ,'0', '1', '2', '3', '4', '5', '6', '7', '8', '9/LeftMargin := 0; /StartNewLineAndIndent; /LeftMargin := ActualLeftMargin; ,end; )WriteSymbol; )if Character = '$' then ,er; ,ReadACharacter; )until not (Character in Digits + [ '.' ]); )if Character in [ 'B', 'b', 'E', 'e' ] )then ,begin /ChaCompilerDirectives; )if Character = '[' then ,DoFormatterDirectives; )if StopCharacter = '}' )then ,while Character <> StoprNumber := CharNumber + 1; /Symbol [ CharNumber ] := Character; /ReadACharacter; /if Character in Digits + [ '+', '-' ] /theCharacter do /CopyACharacter )else ,repeat /while Character <> '*' do 2CopyACharacter; /CopyACharacter; ,until Character n 2repeat 5CharNumber := CharNumber + 1; 5Symbol [ CharNumber ] := Character; 5ReadACharacter; ������������������������������B�� ': /numbers; ,' ': /begin 2repeat 5ReadACharacter 2until Character <> ' '; 2ReadSymbol /end {' '}; ,'>', ':': /CheckFoangeMarginTo }; procedure DoDeclarationUntil(EndDeclaration: SymbolSet); # # # # #procedure DoParentheses; & &var ���r('=', OtherSymbol, ReadNextCh); ,'<': /begin 2CheckFor('=', OtherSymbol, ReadNextCh); 2if SymbolName <> OtherSymbol then 5,SavedLgLnId: OptionSize; ) &begin )SavedLgLnId := LongLineIndent; )if DeclarAlignment > 0 )then ,begin /LongLineIndent CheckFor('>', OtherSymbol, DontReadNextCh); /end {'<'}; ,'.': /if LastSymbol <> EndSymbol /then 2CheckFor('.', Range, ReadN:= WriteColumn + SymbolGap + 1 - LeftMargin - 0WriteLeftCol; /CopySymbol([ RightParenth ]); /WriteRead; ,end )else ,begin extCh) /else 2SymbolName := PeriodSymbol; ,'''': /begin 2CharNumber := 0; 2repeat 5repeat 8CharNumber := CharNumber + 1;/LongLineIndent := 1; /ChangeMarginTo(ActualLeftMargin + IndentIndex); /StartNewLineAndIndent; /CopySymbol([ RightParenth ]) 8Symbol [ CharNumber ] := Character; 8ReadACharacter; 5until Character = ''''; 5CharNumber := CharNumber + 1; 5Symbol [ Ch; /WriteRead; /ChangeMarginTo(ActualLeftMargin - IndentIndex); ,end; )LongLineIndent := SavedLgLnId; &end { DoParentheses }arNumber ] := Character; 5ReadACharacter; 2until Character <> ''''; 2Length := CharNumber; 2SymbolName := OtherSymbol; �����; # # # # #procedure DoFieldListUntil(EndFieldList: SymbolSet); & &var 0 I : Integer; 0LastEOL: PlaceMarker; ,Alig/end {String} )end {case} &else )if Character = Chr(Tab) )then ,begin /repeat 2ReadACharacter /until Character <> Chr(TnColumn: Width; ) & & & &procedure DoRecord; ) )var +SavedLeftMargin: Width; , )begin ,SavedLeftMargin := ActualLeftMab); /ReadSymbol ,end {Tab} )else ,begin /Symbol [ 1 ] := Character; /SymbolName := NameOf [ Character ]; /Length := 1; argin; ,WriteSymbol; ,ReadSymbol; ,ChangeMarginTo(WriteColumn - 6 + IndentIndex - WriteLeftCol); ,StartNewLineAndIndent; ,D/ReadACharacter ,end {else} #end { ReadSymbol }; Procedure Writereaad; { Copy a Symbol } # #begin &WriteSymbol; &ReadSoFieldListUntil([ EndSymbol ]); ,ChangeMarginTo(ActualLeftMargin - IndentIndex); ,StartNewLineAndIndent; ,WriteSymbol; ������ymbol; #end { Writereaad }; Procedure CopySymbol(S: SymbolSet); # #begin &repeat )WriteRead; &until SymbolName in S; ,ReadSymbol; ,ChangeMarginTo(SavedLeftMargin); )end { DoRecord }; & & & & &procedure DoVariantRecordPart; ) )var +Sav#end { CopySymbol }; procedure ChangeMarginTo(NewLeftMargin: Margins); # #var "IndentedLeftMargin: Margins; & #begin &edLeftMargin, *OtherSavedMargin: Margins; , )begin ,OtherSavedMargin := ActualLeftMargin; ,if DeclarAlignment > 0 ,then /ActualLeftMargin := NewLeftMargin; &LeftMargin := NewLeftMargin; &if LeftMargin < 0 &then )LeftMargin := 0 &else )begin ,begin 2CopySymbol([ ColonSymbol, OfSymbol ]); 2if SymbolName = ColonSymbol 2then 5begin 8WriteRead; 8with UnWritten [ LastIndentedLeftMargin := WriteRightCol - 9 - LongLineIndent; ,LeftMargin := Min(LeftMargin, IndentedLeftMargin); )end; #end { ChEOL.BuffPointer ] do ;if ChIsEndLine then >begin AIndentAfterEOL := Max(IndentAfterEOL + BAlignColumn - WriteColumn, 0); >e�C�� astEOL := Place; )if LastSymbol = LeftParenth then ,for I := 1 to DeclarAlignment - Length do /WriteA(' '); )AlignColumn := ); /WriteRead; ,end; )if SymbolName = ColonSymbol then ,CopySymbol([ Semicolon ]); )WriteRead; )ChangeMarginTo(ActualLeftMLeftMargin + WriteLeftCol + DeclarAlignment + 1; )while not (SymbolName in EndFieldList) do ,begin ���������������������������argin + IndentIndex); )StartNewLineAndIndent; )LastProgPartWasBody := False; )DoBlock(ProcName, ProcNmLength); )LastProgPart/if LastSymbol in [ Semicolon, Comment ] then 2if SymbolName <> Semicolon then 5begin 8StartNewLineAndIndent; 8LastEOL := PWasBody := True; )ChangeMarginTo(ActualLeftMargin - IndentIndex); )WriteRead; )StartNewLineAndIndent; &end { DoProcedures };nd; 8WriteColumn := AlignColumn; 8ChangeMarginTo(ActualLeftMargin + AlignColumn - 9WriteColumn); 5end; /end; ,if SymbolNamlace; 5end; /if SymbolName in [ RecordSymbol, CaseSymbol, LeftParenth, 0CommaSymbol, ColonSymbol, EqualSymbol ] /then 2casee <> OfSymbol then /CopySymbol([ OfSymbol ]); ,ChangeMarginTo(ActualLeftMargin + IndentIndex); ,repeat /WriteRead; /if Symb SymbolName of 5RecordSymbol: 8DoRecord; 5CaseSymbol: 8DoVariantRecordPart; 5LeftParenth: 8DoParentheses; 5CommaSymbol, ColName <> EndSymbol /then 2begin 5StartNewLineAndIndent; 5CopySymbol([ LeftParenth, Semicolon, EndSymbol ]); 5if SymbolNameolonSymbol, EqualSymbol: 8CommaColonEqual; 2end {case} /else 2begin 5WriteSymbol; 5ReadSymbol 2end; ,end; &end { DoFiel = LeftParenth 5then 8begin ;WriteRead; ;SavedLeftMargin := ActualLeftMargin; ����������������������������������������������dListUntil }; # # # # #begin { DoDeclarationUntil } &StartNewLineAndIndent; &WriteSymbol; &ChangeMarginTo(ActualLeftMarg;ChangeMarginTo(WriteColumn - WriteLeftCol); ;DoFieldListUntil([ RightParenth ]); ;WriteRead; ;ChangeMarginTo(SavedLeftMargiin + IndentIndex); &StartNewLineAndIndent; &ReadSymbol; &DoFieldListUntil(EndDeclaration); &StartNewLineAndIndent; &ChangeMn); 8end; 2end; ,until SymbolName <> Semicolon; ,ChangeMarginTo(OtherSavedMargin); )end { DoVariantRecordPart }; & & & arginTo(ActualLeftMargin - IndentIndex); #end { DoDeclarationUntil }; procedure DoBlock(BlockName: CommentText; BlockNmLeng& &procedure CommaColonEqual; ) )begin ,WriteSymbol; ,if DeclarAlignment > 0 ,then /if not (EndLabel <= EndFieldList) /tth: Width); # #var 3I: Width; #IfThenBunchNeeded: Boolean; %AtProcBeginning: Boolean; & # # # �������������������������hen 2begin 5with UnWritten [ LastEOL.BuffPointer ] do 8if ChIsEndLine then ;begin >IndentAfterEOL := Max(IndentAfterEOL + #procedure DoProcedures; & &var 6I: 0 .. 20; /ProcName: CommentText; +ProcNmLength: Width; ) &begin )for I := 2 to Proc?AlignColumn - WriteColumn, 0); >WriteColumn := AlignColumn; ;end; 5if SymbolName = CommaSymbol then 8begin ;StartNewLineAnSeparation do ,StartNewLineAndIndent; )StartNewLineAndIndent; )if SymbolName = SegSymbol then ,WriteRead; )WriteRead; )ProdIndent; ;LastEOL := Place; 8end; 2end; ,ReadSymbol; )end { CommaColonEqual }; & & & & &begin { DoFieldListUntil } )LcName := Symbol; )ProcNmLength := Length; )WriteRead; )if SymbolName = LeftParenth then ,begin /CopySymbol([ RightParenth ]�D�� �d Q option for highlighting brackets []. } { Reworked buffer pointers for small MAxints } { Changed �generated comments to use curly brackets } { Added UCSD file open/close routines } { Fixed some p�roblems in line indenting } { Added error messages for invalid directives } { Repaired string {[Q=1, A=15, E=3, L=1, P=4, I=3] FORMATTER DIRECTIVES. } {$D3} {  }  {*******************************************truncation problems } { Added UCSD space compression codes } { Added TAB character ****************} { } { P A S C A L P R O G R A M F O R M A Thandling } { Modularized long procedures } { Added procedures for oft T E R } { ----------------------------------------------- } { en repeated sequences } { Removed dependence on buffersize + or - 1 symbols } �������������������������������� # ��������������������������������������������������������������������������������������������������������������������������� } { AUTHOR: MICHAEL N. CONDICT, 1975. } { LEHIGH UNIVERSITY � } { CURRENT ADDRESS: PAR CORP. } { 228 LIBERTY PLAZA ��A ����������������������������������������������������������������������������������.������������������������O��^�} { ROME, NY 13440 } { } { ���B����������������������������������������������������������������������������������������������������������������������� UPDATED: AUGUST, 1978. } { } { La�test update: 8 Oct 1979 } { E. Schleske, G. Gonzalez } �����������{ } { Removed all unneeded Pack, Unpacks. } { �Removed CDCisms in Alfalength. } { Added support for lower case input and curly comments } { Adde�E�� ent, CompoundStatement, OtherStatement); )Symbols = (ProgSymbol, Comment, BeginSymbol, EndSymbol, Semicolon, 5ConstSymbol, Typ Width; #SymbolIsNumber, LastProgPartWasBody: Boolean; +Digits, !LettersAndDigits: CharSet; ,IdMax: Integer; ,Place, (NexteSymbol, RecordSymbol, ColonSymbol, 5EqualSymbol, PeriodSymbol, Range, CaseSymbol, OtherSymbol, 5IfSymbol, ThenSymbol, ElseSymPlace: PlaceMarker; -Main: CommentText; %MainNmLength: Width; (UnWritten: array [ Width ] of BufferEntry; %PascalSymbol: arrbol, DoSymbol, OfSymbol, 5ForSymbol, WithSymbol, WhileSymbol, RepeatSymbol, 5UntilSymbol, Identifier, VarSymbol, ProcSymbol, Fay [ 1 .. SymbolRoom ] of Alfa; #PascSymbolName: array [ 1 .. SymbolRoom ] of Symbols; +NameOf: array [ Char ] of Symbols; "SuncSymbol 5, SegSymbol, LeftBracket, RightBracket, CommaSymbol, 5LabelSymbol, LeftParenth, RightParenth, AlphaOperator); �����tatementTypeOf: array [ Symbols ] of StatmntTypes; # Function Min(I, J: Integer): Integer; # #begin &if I < J &then )Mi+Width = 0 .. BufferSize; )Margins = - 100 .. BufferSize; 'SymbolSet = set of Symbols; &OptionSize = - 99 .. 99; $SymbolStrn := I &else )Min := J; #end { Min }; Function Max(I, J: Integer): Integer; # #begin &if I > J &then )Max := I &elsing = array [ Width ] of Char; %CommentText = SymbolString; %BufferEntry = Packed record DChIsUsed: Boolean; <Case ChIsEndLie )Max := J; #end { Max }; function UpperCase(Character: char): char; # #begin &if Character in [ 'a' .. 'z' ] &then ne: Boolean of Afalse: ( Ch: Char); Atrue: ( IndentAfterEOL: Margins) ;end; %PlaceMarker = record :BuffPointer:)UpperCase := Chr(Ord(Character) + Ord('A') - Ord('a')) &else )UpperCase := Character; #end { UppercAse }; �������������� Width; <CharCount: Integer; 4end; # var .INP, .OUT: Text; $InputFileName, #OutputFileName: String; *ChIsEOL, &NextChIsprocedure ConstantsInitialization; #var (I: Integer; # # # # #procedure SetPas; & & & & &Procedure Define(Name: AlfaEOL: Boolean; (Character: Char; 'ReadColumn, %ReadRightCol: 0 .. 1000; (OutputCol, &WriteColumn, 'LeftMargin, !ActualLeft; Sym: Symbols); ) )begin ,IdMax := IdMax + 1; ,PascalSymbol [ IdMax ] := Name; ,PascSymbolName [ IdMax ] := Sym; )end { D{ Cleaned up usage of Min and Max } { } {***Margin, &ReadLeftCol, %WriteLeftCol, $WriteRightCol: Margins; &DisplayIsOn, "ProcNamesWanted, EndCommentsWanted, &PackerIs********************************************************} program Format; const &AlfaLength = 9; )MinChar = 0; )MaxChar = 12Off, 'SavedBunch, &BunchWanted, %NoFormatting: Boolean; 'LineNumber, (Increment: Integer; &IndentIndex, #LongLineIndent, 7; &BufferSize = 160; &SymbolRoom = 40; !MaxReadRightCol = 999; MaxWriteRightCol = 80; # type ,Alfa = Packed array [ 1.. Al(SymbolGap, 'BracketGap, "DeclarAlignment, !StatmtSeparation, #ProcSeparation: OptionSize; 'LastSymbol, ������������������faLength ] of char; )CharSet = set of Char; $StatmntTypes = (ForWithWhileStatement, RepeatStatement, IfStatement, 5CaseStatem'SymbolName: Symbols; %AlphaSymbols, )EndLabel, )EndConst, *EndType, +EndVar: SymbolSet; +Symbol: SymbolString; +Length:�F�� efine('END ', EndSymbol); )Define('CONST ', ConstSymbol); )Define('TYPE ', TypeSymbol); )Define('VAR ', VarS&NameOf [ '>' ] := EqualSymbol; &NameOf [ ';' ] := Semicolon; &SetPas; &for SymbolName := ProgSymbol to AlphaOperator do )Symbol); )Define('RECORD ', RecordSymbol); )Define('CASE ', CaseSymbol); )Define('IF ', IfSymbol); )Define('THEN tatementTypeOf [ SymbolName ] := OtherStatement; &StatementTypeOf [ BeginSymbol ] := CompoundStatement; &StatementTypeOf [ Cas ', ThenSymbol); )Define('ELSE ', ElseSymbol); )Define('DO ', DoSymbol); )Define('OF ', OfSymbol); )DefineSymbol ] := CaseStatement; &StatementTypeOf [ IfSymbol ] := IfStatement; &StatementTypeOf [ ForSymbol ] := ForWithWhileStateme('FOR ', ForSymbol); )Define('WHILE ', WhileSymbol); )Define('WITH ', WithSymbol); )Define('REPEAT ', RepeatSyent; &StatementTypeOf [ WhileSymbol ] := ForWithWhileStatement; &StatementTypeOf [ WithSymbol ] := ForWithWhileStatement; &Stmbol); )Define('UNTIL ', UntilSymbol); )Define('PROCEDURE', ProcSymbol); )Define('FUNCTION ', FuncSymbol); ���������������atementTypeOf [ RepeatSymbol ] := RepeatStatement; #end { ConstantsInitialization }; procedure OpenOut; # #var /Error: b)Define('SEGMENT ', SegSymbol); )Define('LABEL ', LabelSymbol); )Define('IN ', AlphaOperator); )Define('MOD 'oolean; & #begin &repeat )Write('Output file:'); )ReadLn(OutputFileName); )Error := OutputFileName = ''; )if not Error ), AlphaOperator); )Define('DIV ', AlphaOperator); )Define('AND ', AlphaOperator); )Define('OR ', AlphaOperatothen ,begin /if Pos('.TEXT', OutputFileName) = 0 then 2OutputFileName := Concat(OutputFileName, '.TEXT'); {$I- } /Rewrite(OUr); )Define('NOT ', AlphaOperator); )Define('ARRAY ', AlphaOperator); )Define('NOSYMBOL ', Identifier); &end { SetPaT, OutputFileName); {$I+ } /Error := IOResult <> 0; /if Error then 2WriteLn('Can''t open output file ', OutputFileName); ����s }; # # # # #begin { ConstantsInitialization } &Main [ 1 ] := 'M'; &Main [ 2 ] := 'A'; &Main [ 3 ] := 'I'; &Main [ 4 ],end; &until not Error; #end { OpenOut }; function Open(InFile: string): boolean; # #begin  {$I-} &Close(Inp); &Rese := 'N'; &MainNmLength := 4; &for I := 0 to BufferSize do )UnWritten [ I ].ChIsUsed := false; &for Character := Chr(MinChar)t(Inp, InFile); {$I+} &Open := IOResult = 0; #end { Open }; procedure OpenIn; { Ask for input file } # #var /Error: boo to Chr(MaxChar) do )NameOf [ Character ] := OtherSymbol; &Character := ' '; &NameOf [ '(' ] := LeftParenth; &NameOf [ ')' ]lean; & #begin &repeat )Write(' Input file:'); )ReadLn(InputFileName); )if InputFileName <> '' )then ,begin /if Pos('.T := RightParenth; &NameOf [ '=' ] := EqualSymbol; &NameOf [ ',' ] := CommaSymbol; &NameOf [ '.' ] := PeriodSymbol; &NameOf [EXT', InputFileName) = 0 then 2InputFileName := CONCAT(InputFileName, '.TEXT'); /Error := not Open(InputFileName); /if Error efine }; & & & & &begin { SetPas } )Idmax := 0; )Define('PROGRAM ', ProgSymbol); )Define('BEGIN ', BeginSymbol); )D '[' ] := LeftBracket; &NameOf [ ']' ] := RightBracket; &NameOf [ ':' ] := ColonSymbol; &NameOf [ '<' ] := EqualSymbol; ������G�� AfterEOL) <); 5OutputCol := IndentAfterEOL + 1; 2end; ,end {with}; &end { OutEndLine }; # # # # #begin { WriteA } ���� ReadColumn + 1; 8Get(Inp) 5end /end {while}; &if NextChIsEOL &then )begin ,Character := ' '; ,NextChIsEOL := False; ,C&With Place do )begin ,CharCount := CharCount + 1; ,BuffPointer := (BuffPointer + 1) mod BufferSize; ,NextPlace.CharCount :hIsEOL := True; ,ReadColumn := 1; ,if NoFormatting then /begin 2WriteColumn := WriteLeftCol; 2MakeEOL(WriteColumn - 1); /ethen 2WriteLn(Chr(7), 'Can''t find ', InputFileName); ,end; &until not Error; #end { OpenIn }; procedure WriteA(Characte= Place.CharCount + 1; ,NextPlace.BuffPointer := (Place.BuffPointer + 1) mod BufferSize; ,with UnWritten [ BuffPointer ] do /r: Char); # #const )SpaceEater = 16; { Space Compression Code } & #var 3I: Width; .TestNo: Integer; & # # # #procedubegin 2if ChIsUsed then 5begin 8if ChIsEndLine 8then ;OutEndLine 8else ;begin >Write(Out, Ch); >OutputCol := OutputCol re OutEndLine; & & & & &procedure RightLineNumbers; ) )begin ,I := WriteRightCol - OutputCol + 1; ,if I > 0 then /Writ+ 1; ;end; 5end { If not empty }; 2ChIsEndLine := false; 2Ch := Character; 2ChIsUsed := true; 2WriteColumn := WriteColumn e(OUT, ' ': I); ,TestNo := LineNumber; ,I := 0; ,repeat /TestNo := TestNo div 10; /I := I + 1; ,until TestNo = 0; ��������+ 1; /end {with}; )end { with } #end { WriteA }; Procedure MakeEOL(Col: Width); # #begin &WriteA(' '); &With UnWritte,Write(OUT, '0000000000': (6 - I), LineNumber: I); ,LineNumber := LineNumber - Increment; ,if LineNumber > 9999 then /LineNun [ Place.BuffPointer ] do )begin ,ChIsEndLine := true; ,IndentAfterEOL := Col; )end {With}; #end { MakeEOL }; procedurmber := LineNumber - 10000; ,WriteLn(OUT); )end { RightLineNumbers }; & & & & &procedure LeftLineNumbers; ) )begin ,Wre FlushUnwrittenBuffer; #var (I: Integer; # #begin &MakeEOL(0); &WriteColumn := 0; &for I := 1 to BufferSize do )WriteA(iteLn(OUT); ,if Increment > 0 then /begin 2Write(OUT, LineNumber: 4, ' '); 2LineNumber := LineNumber + Increment; /end {if}' '); #end { FlushUnwrittenBuffer }; procedure StartNewLineAndIndent; # #begin &if PackerIsOff and DisplayIsOn then ���� )end { LeftLineNumbers }; & & & & &begin { OutEndLine } )with UnWritten [ Place.BuffPointer ] do ,begin /if IndentAfte)begin ,LastSymbol := PeriodSymbol; ,WriteColumn := WriteLeftCol + LeftMargin; ,MakeEOL(WriteColumn - 1); )end; #end { StarEOL < 0 /then 2begin 5Write(OUT, ' ': - IndentAfterEOL); 5OutputCol := OutputCol - IndentAfterEOL; 2end /else 2begin 5irtNewLineAndIndent }; procedure ReadACharacter; # #begin &if ReadColumn > ReadRightCol &then )begin ,if ReadRightCol <f Increment < 0 5then 8RightLineNumbers 5else 8LeftLineNumbers; 5if IndentAfterEOL > 0 5then 8if increment > 0 8then ;W MaxReadRightCol ,then /begin 2NextChIsEOL := True; 2ReadLn(Inp); /end ,else /ReadColumn := 2; )end &else )if ReadColurite(Out, ' ': IndentAfterEOL) 8else { Pascal system space compression sequence } ;Write(Out, Chr(SpaceEater), Chr(32 + Indentmn = 1 )then ,while ReadColumn < ReadLeftCol do /begin 2if EOLn(Inp) 2then 5ReadColumn := 1 2else 5begin 8ReadColumn :=�H�� umn <= WriteRightCol then 8begin ;WriteA(' '); ;NumberBlanksToWrite := SymbolGap - 1; 8end {if}; ,if WriteColumn + Length +� NumberBlanksToWrite - 1 > WriteRightCol ,then /begin 2if PackerIsOff 2then 5begin �����������������������������������������8WriteColumn := WriteLeftCol + LeftMargin + 9LongLineIndent; 8if WriteColumn + Length - 1 > WriteRightCol then ;begin >Writ�eln; >Writeln('*** Symbol too long:'); >For I := 1 to Length do AWrite(Symbol [ I ]); >Writeln; ;end; 5end 2else 5begin �8Length := Min(Length, WriteRightCol - WriteLeftCol + 1) 6; 8WriteColumn := WriteLeftCol; 5end; 2MakeEOL(WriteColumn - 1); �nd; )end &else )if not EOF(Inp) )then ,begin /Character := Inp ^; /ReadColumn := ReadColumn + 1; /NextChIsEOL := EOLn(In/end ,else /for I := 1 to NumberBlanksToWrite do 2WriteA(' '); ,for I := 1 to Length do /WriteA(Symbol [ I ]); )end; &Lap); /Get(Inp); /ChIsEOL := False; /if NoFormatting then 2WriteA(Character); ,end )else ,begin /FlushUnwrittenBuffer; ���stSymbol := SymbolName; #end { WriteSymbol }; procedure CopyACharacter; # #begin &if DisplayIsOn &then )begin ,if Wri/WriteLn('Errors in Pascal program!'); /Exit(Format); ,end #end { ReadACharacter }; procedure WriteSymbol; # #var 3I:teColumn > WriteRightCol then /begin 2while (Character = ' ') and not ChIsEOL do 5ReadACharacter; 2if not ChIsEOL then 5Sta Width; !NumberBlanksToWrite: OptionSize; & #begin &if DisplayIsOn &then )begin ,NumberBlanksToWrite := SymbolGap; ,if (rtNewLineAndIndent; /end; ,if ChIsEOL ,then /begin 2LeftMargin := 0; 2StartNewLineAndIndent; 2LeftMargin := ActualLeftMarLastSymbol in [ LeftParenth, PeriodSymbol ]) or (SymbolName in -[ Semicolon, RightParenth, CommaSymbol, PeriodSymbol, ColonSymbgin; /end ,else /WriteA(Character); )end; &ReadACharacter #end { CopyACharacter };  {$I SPRUCE.A.TEXT } ����������������ol -]) or (SymbolName in [ LeftParenth ]) and (LastSymbol = Identifier -) ,then /NumberBlanksToWrite := 0 ,else /if (Symbo{$I SPRUCE.B.TEXT }  ���������������������������������������������������������������������������������������������������������lName = RightBracket) or ((SymbolName = LeftBracket) 0and (LastSymbol = Identifier)) or (LastSymbol = LeftBracket) /then 2Num�berBlanksToWrite := BracketGap /else 2if (SymbolName in AlphaSymbols) and (LastSymbol in 3AlphaSymbols) 2then 5if WriteCol��I�� �nge of [1..100]  In source line: AGELIST[ I ] := AGE ;  Variables in Procedure INDEX:   NAME :='Jane Smith' AGE � := 25  SINGLE := TRUE TEMP := 98.6  SEX := ORD( 1) TITLE :='Vice-President'  I � := 101 J := 12   .OPTION( F+ )  #Thus the user has the essential information for diagnosin .TITLE Symbolic Post-Mortem-Dump for the UCSD Pascal system  .INPUT( B~ H| U_ )  .OPTION( L- R- )  .MARGIN( R60 )  0Georg the  problem i.e. The value of the variable 'I' is apparently outside the  allowable range of indexes for array AGELIST.  ge Gonzalez 0University Computer Center 0(C) 1979 University of Minnesota .MARGIN  .OPTION( L+ R+ )  #The UCSD Pascal syst #  _PMD Commands_  #After displaying the above information, PMD prompts for user  commands with the line:  %PMD: Up, Tem is generally a very easy to use system,  with one major exception. The exception is the case when a program  'blows up' wiop, Down, Edit, Quit:  #The user can choose one of the listed commands by pressing the ��������������������������������������th a fatal error. In this instance the system provides  a cryptic message such as: "Value range error S#1, P#12, IPC#12118"   first letter of the command. The Up, Down, and Top commands are used  to traverse the chain of procedure and function calls plus an optional octal dump. This information is of little use to  the average user; it doesnt illuminate the cause of the proactive at the  time the error occurred. They allow one to trace the flow of  execution back to the main program and inspect t������������������������������������������������������������������������������������������������������������������������F��^�blem.  #The symbolic Post-Mortem-Dump enhancement (hereafter called PMD)  was developed to alleviate this problem. It come�s into play when a  program blows up. Instead of printing a cryptic series of numbers,  PMD displays: ( %1) A general error� message. %2) Any specific error information available. %3) The source statement which caused the error. ���������������������� 4) The name of the Procedure, Function, or Program )which contains the error. %5) The values of (simple) program variab�les.  % !A typical error display might look like:   .OPTION( F- )  Value Range error  Invalid Value was 101, outside ra�J�� r occurred. % #_Top_: Moves one to the 'top' level, i.e. the main program level.  Equivalent to pressing many 'Up' commands,are invalid.  ^Char~~~~~~~~~Any value outside the ASCII range [0..255] is in|valid.   ^String~~~~~~~A string is considered i but faster. #_Edit_: Takes one into the screen-oriented Editor and positions the  cursor at the line in error. Works much lnvalid if it contains any non-printing  char|ac|ters (Ordinal positions [0..31] ).   ^Scalar~~~~~~~A scalar is considered inike the E(dit command when  the compiler detects an error. Note that this option is only active  if the {$D3} compiler optionvalid if its ordinal is negative  or exceeds 200. This is a generous limit as the Pascal  compiler cannot handle much over 17 (described below) is selected.  #_Quit_: Exits one from PMD and returns to the system level  prompt|line.  % �����0 identifiers.   ^Pointer~~~~~~A pointer is considered invalid if it is non-NIL and does  not point into the heap storage ar _Notes:_  #The amount of debugging information provided can be controlled by  selectively using the {$D} compiler option. ea.   .MARGIN   _Bugs and limitations:_  #Only simple variables can be displayed. They must be of types  integer, The default option is  {$D2}. {$D3} is the recommended level for all but very large  programs that need the extra 10% of mem real, char, boolean, string, pointer, scalar, or a subrange  of these. No arrays, records, sets, files, or file windows can bory that level 3 consumes.  Levels {$D2} and lower use no extra memory.   .MARGIN( L15 )  .PARAGRAPH( F^ U13 )   ^{$D0}~e  shown.  #The Edit command only works correctly if the source file in error ����������������������������������������������~~~~~Provides no error information except for the generic error  message.   ^{$D1}~~~~~~Provides the name of the procedure i is the current workfile. This is almost always true when one is  debugging a program.  #PMD may point to an incorrect soun error.   ^{$D2}~~~~~~Provides $D1 information, plus information about  the variables.   ^{$D3}~~~~~~Provides $D2 levelrce line if the error occurred in  a source file which was included with the {$I} compiler option.  #Any VAR parameters to a information, plus information  about the specific source line in error.This option  adds about 10% to the length of the code  procedure or function are not displayed.  #PMD may cause a **Stack Overflow** condition if the program in  error uses almosfile.   .MARGIN  #PMD displays the value '*NOT SET*' when it determines a variable  has an invalid value. The rules it ut all of memory for code and static (non-pointer)  variables.   _Installation notes_  #The PMD feature is currentlyhe variables local to  each level.  #_Up_: Moves one 'up' a level, i.e. to the procedure or function  which called the currses to determine validity are  diagrammed below. #_Type Valid range_  .MARGIN( L17 )  .PARAGRAPH( F^ U13 )  �����ent one.  #_Down_: Moves one 'down' a level, i.e. to the called procedure. The  lowest level is the level at which the erro ^Integer~~~~~~All values are valid.  ^Real~~~~~~~~~All values are valid.  ^Boolean~~~~~~Any values other than TRUE or FALSE �K�� #թթǝcթ������%ժ񧂷�Ǡ�իի"ի4ʂǜǠ�#ի{ի&իʕǜǠ�#իիլ {ܲՅ�Ǡ�}Յ Յ ՅՅ�Ǡ�}Ն�Ǡ�}Ն&Ն4٫ՆQ�Ǡ�}ՆjՆ�F����.Շ3 only available on the UCSD Pascal  I.4g system. This system consists of the following files, all of  which must be present fլǜǠ�#լ6�����x�'լȧǜǠ�լ⧂�šխխ��"խ3ápխ[խg!խoG�Ǡ�խ#խխڢor the PMD feature to function.  #SYSTEM.INTERP P-code interpreter #SYSTEM.PASCAL Operating system kernel, ver���ǜǠ�ծծǜǠ�ծ2ǜǠ�#ծiծpծvˡծ����"ծʂǜǠ�#ծծ!ծsion I.4g #SYSTEM.COMPILER Pascal compiler, version I.4g #SYSTEM.FILER System file utility, version I.4g #SYSTEˡuկ"կ:կH����"կu!áOկկ!կǜǠ�հǜǠ�#հ@�����&հ_!հqǜǠ�#հհհM.SYNTAX Error message file, version I.4g  #See the I.4g information file for other features specific to the ���������ڪPՂ�0Ղ�Ղ00Ղ0/�1/1ȡ%Ճ /�áՃ8 //ՃQKՃk/0Ճx.1.1ȡ+Ճ0. I.4g system. �����������������������������������������������������������������������������������������������������������������.ˡՃ..Ճ0Ճ٭?���\�� ��Մ ��Մ3 SYSTEM.INTER��ՄV�`mՄjՄtCan't find int�erpreter!!�����Մ`mՄ`mՄՄ Մ�ՄB`mՅ�S`mՅ*S`mՅ?�B`mՅZ�ՅdDon't recognize extension of:���������Յ\ՅՅ��Յߧ��� changed to �����fՉs�ˡՉՉՉ˹/Չš&ՉՊ�ˡՊՊJՊ^Պn�����ՊՊՊՊ�ՊՊՋȄĄȄˍ1ՋՋˍˍՋՌ  ՌZՌqޫՌݫՌ� ����Ս�Ս+Ս@ՍOՍaȡXՍ|ՍՍۂՍڂՍՍՎ�؂Վ؂Վ2؏ՎT؏ՎsՎ��c��� �� Տ�ˡՏ8ՏH���AڊՏ_يՏo9=Տ؊Տ9=Տ Տ ՏڂՏ� ՃՄؑǜǠ�Մ-Մ4Մ;���� ��-ՄূՄܨՅ}�Ǡ�Յ- ՅF�Ǡ�{Յ]�Ǡ�}ՅqՅ�L�� ���թj$ *** Errors found in Pascal program.�����թeթթProgram ������ Spruced into f�RADIUS ������������������������������������������������������������������������������������������������������������������ile ���]�����թ��ժժ������5Ɓ/�Ɓ0Ƃ\�ժZժh4ժr ժ}ժ0��� (ժ ***� Empty file.�����Sժժժժ姂�ˡ4ի *** "PROGRAM" was expected.�����իA5իHիM��Ɓ0����4�����r j h XT ^P>|r !F"2#%8'''))((*++1.,h111j�5MթUթ_ˡՇTՇ`!Շf˶ˡՇՇՇ�Ǡ�,ՈՈHՈxǝc-Ո$Ո�ՈӶ�Ǡ�ՈՈՉ�Ǡ�Չ-Չ4ՉC�������� ��0ՉՉ!ՉˡyՉՉЧ~Ä/��� M�H�B�=��:�՜ ʀ�Ǡ�՜6ʕǜǠ�#՜]�\�b� �$,٨՜~Ä~՜㧂 á ՝ּ$՝&á ՝ՊD.ՊMՊcՊ�Պ�Ǡ�,ՊҶ�Ǡ�ՊՋ)0Ջ0ՋDՋdǝcYӼ$՝iá ՝м$՝á ՝ۥͼ$՝짂˳���՞2+՞8á՞`՞e~/՞�Ǡ�̀�Ǡ�̀ʀ-ՋՋՋdz�"Ռ=Ռ1Ռ6á Ռ[Ÿ ՌȸՌǝc-ՌՌ,Սçʀȡ՞ʀ̀՞�̀՞̀՟ʕǜǠ�#՟2ƀ�Ǡ�,՟{~՟ʂǜǠ�#՟՟!՟ՠ��{��J�ՍOڧՍ. ՍՍ.Ս����^/ՎܨՎ!}�Ǡ�Վ9�"ՎbՎkՎ!ՎՎ �:*ՠe������ՠ��������աٳ �բֳ�d�գZӥּ գХ�Ǡ�,ՎՏ Տ"ǝc-ՏHՏbǝc-ՏՏáՏՏܨՐӼ@գͥм���գ�ǜǠ�դ �ǜǠ�դ%�ǜǠ�դ7ǜǠ�դKǜǠ�դ`�դǜPLACE 1S �1I /�1J .�1K -�1BASE 0�1���������������������������������������������������������դPǜǠ�դ�Ǡ�դդ�դ�ե7եN�եfեե�ե�եǝcզ ǝcզ!ǝc�զ3ǝcզLǝcզd�ǝcզw�ǝcզ�զ�զ�զ��Ǡ�Ǡ��Ǡ�ȡէ�Ǡ� է�" էI�~էY�0���� �4ըcըp!ըxܨը}�Ǡ�Fը"ը!ըըꥃF�Ǡ�*թ. թ%թ+ ˡMթUթ_