`L i=L\Ʃx ? N'i  ͭЅ?0ȱ Ѕ?iȱi lԠԠ͠ԠϠŠͮŠ SYSTEM.APPLE   L$JB N^vg PMU.PROC.TEXTvgCPMU.TEXTr=vgH RECOVER2.TEXTvgS PZAP2.TEXT=vgǢ SAVEFOTO.TEXT{ KYBDDEMO.TEXTvgآKYBDSTUFF.TEXTgآ CRTUTL.TEXTvg6DIR.TEXTr=vgTF.TEXTr=DPTH2.1 PBMENU.TEXTvg" PBUNIT.TEXTvg", PBPROC.TEXTvg,0 DOS32K.TEXTvg0X DECODE.TEXTvgXd CODEMAP.TEXTvgUdl PATCHOS.TEXTvgl~ TRANSFER.TEXTvg~ PUFFIN.TEXT{&꽌ɪɖ'*&%&,E'зЮ꽌ɪФ`+*xH&x'8*7Ixix&&  ') + &п x) ++`FG8`0($ p,&") (jJJ>L+ "?I>  N `  ` x V Nx .x- z `V0^*^*>` aI꽌ɪVɭ&Y&&Y& 꽌ɪ\8`&  (*********************************************)  (* LISTING #1: PBMENU, A PASCAL+BASIC HYBRID *)  (* *)  (* WRITTEN BY RON DEGROAT 3/81 *)  (*********************************************)    BEGIN "REPEAT #GOTOXY(0,STARTMENU+2*SELECTION); #WRITE(SP:14,INVERSE,MENU[SELECTION]); #READ(KEYBOARD,CH); #IF (CH=LEFT) OR (CH=RIGHT) THEN $BEGIN %GOTOXY(0,STARTMENU+2*SELECTION); %WRITELN(NORMAL,SP:14,MENU[SELECTION]); %IF CH=RIGHT THEN NEXT:ND OPTIONS'); "GOTOXY(0,STARTMENU); "FOR I:=0 TO NUMOPTIONS-1 DO $BEGIN &WRITELN(SP:14,MENU[I]); &WRITELN; $END; "PROMPTAT(22,'LEFT & RIGHT ARROWS MOVE CURSOR'); "PROMPTAT(23,' OR EXECUTES SELECTION');  END;   PROCEDURE MAKESELECTION;"MENU[2]:='BSAVE'; "MENU[3]:='RUN'; "MENU[4]:='SAVE'; "MENU[5]:='LOAD DOS'; "MENU[6]:='CALL'; "MENU[7]:='ROM CALL'; "MENU[8]:='QUIT'; "SELECTION:=0;  END; (*INITMENU*)   PROCEDURE DISPLAYMENU;  BEGIN "WRITE(HOME); "WRITE('PASCAL+BASIC: COMMAMENU=3; &SP=' ';   TYPE OPTIONS=STRING[10];   VAR MENU:PACKED ARRAY[0..NUMOPTIONS] +OF OPTIONS; + $NEXT,SELECTION:INTEGER; $ $INVERSE,NORMAL, $LEFT,RIGHT:CHAR;   PROCEDURE INITMENU;  BEGIN "MENU[0]:='BRUN'; "MENU[1]:='BLOAD'; PROCEDURE DOIT;  BEGIN !CASE CHOICE OF #0:BINRUN; #1:BINLOAD; #2:BINSAVE; #3:BASICRUN; #4:BASICSAVE; #5:DOS; #6:CALLIT; #7:ROMCALLIT; #8:DONE:=TRUE; !END; (*CASE*)  END; (*DOIT*)    PROCEDURE MENUOPTIONS;   CONST NUMOPTIONS=9; &START;  END; (*CALL*)   PROCEDURE ROMCALLIT;  BEGIN "GETADDR('ROM ADDR TO CALL ==> '); "ROMCALL(ADDR);  END; (*ROMCALL*)   PROCEDURE DOS;  BEGIN !FILENAME:='DOS.3.3'; SUFFIX:=BIN; !FILECHK; !WRITE('NOW LOADING DOS...'); !LOADDOS;  END;   !SUFFIX:=BAS; !GETFILENAME; FILECHK; !RUN(FILENAME);  END; (*RUN*)  "  PROCEDURE BINRUN;  BEGIN "SUFFIX:=BIN; "GETFILENAME; FILECHK; "BRUN(FILENAME);  END; (*BRUN*)  "  PROCEDURE CALLIT;  BEGIN "GETADDR('ADDR TO CALL ==> '); "CALL(ADDR)('STARTADDR ==> '); !PROMPTAT(4,'LENGTH IN BYTES ==> '); !READLN(CODELEN); !BSAVE(FILENAME,ADDR,CODELEN);  END; (*BINSAVE*)    PROCEDURE BASICSAVE;  BEGIN !GETFILENAME; !SAVE(FILENAME);  END; (*SAVE*)    PROCEDURE BASICRUN;  BEGIN ,'REQUIRES COMPLETE FILE NAME'); "PROMPTAT(23,'INCLUDING SUFFIX (BAS,BIN,CODE)'); "GETFILENAME; "SUFFIX:=NOTHING; FILECHK; "GETADDR('LOADADDR ==> '); "BLOAD(FILENAME,ADDR);  END; (*BINLOAD*)    PROCEDURE BINSAVE;  BEGIN !GETFILENAME; !GETADDRI+*) !CLOSE(F);  END;   PROCEDURE GETFILENAME;  BEGIN  PROMPTAT(0,'FILENAME ==> '); !READLN(FILENAME);  END;   PROCEDURE GETADDR(PROMPT:STRING);  BEGIN !PROMPTAT(2,PROMPT); !READLN(ADDR);  END;   PROCEDURE BINLOAD;  BEGIN "PROMPTAT(22"IF IOERR=10 THEN #WRITELN('CAN''T FIND ',TESTNAME); "WRITE('PRESS TO CONTINUE'); "READ(CH); EXIT(DOIT); !END;  END; (*IOERRCHK*)   PROCEDURE FILECHK;  BEGIN !TESTNAME:=CONCAT(FILENAME,SUFFIX);  (*$I-*) !RESET(F,TESTNAME); IOERRCHK;  (*$STRING);  BEGIN "GOTOXY(0,LINE); "WRITE(MESSAGE,ERASEOL);  END; (*PROMPTAT*)    PROCEDURE IOERRCHK;  VAR IOERR:INTEGER;  BEGIN !IOERR:=IORESULT; !IF IOERR<>0 THEN BEGIN "CLOSE(F); "WRITELN(BELL); "WRITELN('IO ERROR #',IOERR); :FILE; $TESTNAME,FILENAME :STRING[25]; $SUFFIX :STRING[5]; $ADDR,CODELEN,NUMBLKS,I :INTEGER; $DONE :BOOLEAN; $  PROCEDURE DOIT(CHOICE:INTEGER); FORWARD;   PROCEDURE PROMPTAT(LINE:INTEGER; MESSAGE:(*$S+,V-*)  PROGRAM PBMENU;   USES BASICSTUFF;   CONST BAS='.BAS'; (*FILENAME SUFFIXES*) &BIN='.BIN'; &NOTHING=''; & &STARTOFHEAP=3072; (* WITH 80 COL BOARD *) 8(* STARTS AT $800 *)   VAR HOME,ERASEOL,BELL,CH :CHAR; $F =1 &ELSE NEXT:=-1; 'NEXT:=NEXT+NUMOPTIONS; %SELECTION:=(SELECTION+NEXT) MOD NUMOPTIONS; $END "UNTIL CH=SP; "WRITE(NORMAL,HOME);  END;   BEGIN (*MENUOPTIONS*)  !INVERSE:=CHR(18); (*CTL-R*) !NORMAL:=CHR(20); (*CTL-T*) !RIGHT:=CHR(21); (*CTL-U, -> *) !LEFT:=CHR(8); (*CTL-H, <- *) !DONE:=FALSE; ! !INITMENU; ! !REPEAT #DISPLAYMENU; #MAKESELECTION; #DOIT(SELECTION); !UNTIL DONE;  END; (*MENU*)    BEGIN (*MAIN PROGRAM*) "  (*CTL CHARS USED HED:BOOLEAN; $ $PBCODEINFO:PACKED RECORD 1CODELENG,CODEADDR:INTEGER; 1NAME:STRING[25]; 1STARTADDR:INTEGER; 1BASICZERPG:PAGEOFMEM; 1COMMENT:STRING; 1FILLER:ARRAY[0..71] OF INTEGER; /END;   PROCEDURE CALL; EXTERNAL;  PROCEDURE ROMCALL; EXTERNAL; NTPART:INTEGER); ,FALSE:(PTRPART:^INTEGER); +END; % %BYTE=0..255; %PAGEOFMEM=PACKED ARRAY[0..255] OF BYTE;   VAR CHEAT,SOURCE,DEST:MAGIC; $ $SUFFIX:STRING[5]; $ $NUMBLKS,I,IO, $HIMEM,HIMEMADDR, $ENDADDR,RUNADDR,LOADADDR:INTEGER; $ $DOSLOADE PROCEDURE BLOAD(FILENAMEE:UNITSTR; BEGINADDR:INTEGER);  PROCEDURE BSAVE(FILENAME:UNITSTR; BEGINADDR,CODELEN:INTEGER);    IMPLEMENTATION   CONST DOSLOADADDR=22016; &DOSINIT=23940; (* $5D84 *)   TYPE MAGIC=RECORD CASE BOOLEAN OF ,TRUE:(IPROCEDURE RUN(FILENAME:UNITSTR);  PROCEDURE SAVE(FILENAME:UNITSTR);  PROCEDURE BRUN(FILENAME:UNITSTR);  PROCEDURE CALL(ADDR:INTEGER);  PROCEDURE ROMCALL(ADDR:INTEGER);  PROCEDURE MOVEHEAP(OLDLOC,NEWLOC:INTEGER); RY. *)   INTERFACE   TYPE UNITSTR=STRING[25];   VAR BASZERPG:PACKED ARRAY[0..255] OF 0..255; $UNITFID:FILE;   PROCEDURE LOADDOS;  PROCEDURE DOSRESET;  PROCEDURE DISPLAY40;  PROCEDURE DISPLAY80;  FUNCTION FPBASIC:BOOLEAN;  TA 26;   (*REMOVE 'INTRINSIC CODE 25 DATA 26' TO *)  (*MAKE BASICSTUFF A REGULAR UNIT. *)   (* THIS UNIT SHOULD BE COMPILED, THEN *)  (* LINKED TO THE EXTERNAL PROCEDURES *)  (* SHOWN IN LISTING #3, AND INSTALLED *)  (* IN THE SYSTEM.LIBRA  (***********************************)  (* LISTING #2: THE UNIT BASICSTUFF *)  (* *)  (* WRITTEN BY RON DEGROAT 3/81 *)  (***********************************)   (*$S+,V-*)  UNIT BASICSTUFF; INTRINSIC CODE 25 DAN^ $8001*) " "MOVEHEAP(STARTOFHEAP,-32767); " "MENUOPTIONS; " "DISPLAY80; " "MOVEHEAP(-32767,STARTOFHEAP); "  END. RE MAY DIFFER FOR*)  (*EXT. TERMINALS, VIDEO BOARDS, ETC.*)  "BELL:=CHR(7); (*CTL-G*) "HOME:=CHR(12); (*CTL-L*) "ERASEOL:=CHR(29); (*CTL-]*) "  (*DISPLAY ONLY LEFT HALF OF SCREEN*) " "DISPLAY40; "  (*MOVE HEAP FROM $C00 TO PROCEDURE DOSRESET; EXTERNAL;  PROCEDURE DISPLAY40; EXTERNAL;  PROCEDURE DISPLAY80; EXTERNAL;  PROCEDURE INITBASZERPG; EXTERNAL;  FUNCTION FPBASIC; EXTERNAL;   PROCEDURE POKEWORD(ADDR,DATA:INTEGER);  BEGIN "CHEAT.INTPART:=ADDR; "CHEAT.PTRPART^:=DATA;  END; (*POKE*)   FUNCTION PEEKWORD(ADDR:INTEGER):INTEGER;  BEGIN "CHEAT.INTPART:=ADDR; "PEEKWORD:=CHEAT.PTRPART^;  END; (*PEEK*)   PROCEDURE MOVEHEAP;  (*HEAP NORMALLY STARTS AT $C00 (3072) *)   CONST NP=90; ( SOURCE.INTPART:=24145; (* $5E51 *) "DEST.INTPART:=976; (* $3D0 *) "MOVELEFT(SOURCE.PTRPART^,DEST.PTRPART^,47); "DOSRESET; (*CHANGE SOFT ENTRY VEC*) "ROMCALL(DOSINIT);  END; (*DOS*) "  PROCEDURE INITPBCODEINFO;  BEGIN !WITH PBCODEINFO DO  BEGIN "SUFFIX:='.BIN'; "LOADFILE(FILENAME); "ROMCALL(LOADADDR);  END; (*BRUN*)   PROCEDURE LOADDOS;  BEGIN "BLOAD('DOS.3.3.BIN',DOSLOADADDR); "DOSLOADED:=TRUE; "HIMEM:=DOSLOADADDR; (* $$5600 *) "SETHIMEM;  (* SET UP PAGE 3 DOS VECTORS *) !IF SUFFIX='.BAS' THEN (*CLEAR ERR BYTE*) "POKEWORD(LOADADDR-1,0); !BLOAD(FILENAME,LOADADDR);  END; (*LOADFILE*)   PROCEDURE RUN;  BEGIN "SUFFIX:='.BAS'; "LOADFILE(FILENAME);; "SETHIMEM; "ROMCALL(RUNADDR);  END; (*RUN*) "  PROCEDURE BRUN; ILENAME); !IO:=BLOCKREAD(UNITFID,PBCODEINFO,1,0); !CLOSE(UNITFID,LOCK); !BASZERPG:=PBCODEINFO.BASICZERPG; !LOADADDR:=PBCODEINFO.STARTADDR; !IF DOSLOADED THEN CONNECT(189,94,129,94) "ELSE CONNECT(240,253,27,253); ECT(CSWL,CSWH,KSWL,KSWH:BYTE);  BEGIN !BASZERPG[54]:=CSWL; BASZERPG[55]:=CSWH; !BASZERPG[56]:=KSWL; BASZERPG[57]:=KSWH;  END;   PROCEDURE LOADFILE(FILENAME:UNITSTR);  BEGIN !FILENAME:=CONCAT(FILENAME,SUFFIX);  (*GET PBCODEINFO*) !RESET(UNITFID,FE(UNITFID,LOCK);  END; (*BLOAD*)   PROCEDURE SETHIMEM;  VAR HM:PACKED ARRAY[0..1] OF BYTE;  BEGIN  (*CONVERT INTEGER TO ARRAY OF BYTES*) !MOVELEFT(HIMEM,HM,2); !BASZERPG[HIMEMADDR]:=HM[0]; !BASZERPG[HIMEMADDR+1]:=HM[1];  END;   PROCEDURE CONN!END;  END; (*SAVE*)   PROCEDURE BLOAD;  BEGIN !CHEAT.INTPART:=BEGINADDR; !I:=1; !RESET(UNITFID,FILENAME); !WHILE NOT EOF(UNITFID) DO "BEGIN #IO:=BLOCKREAD(UNITFID,CHEAT.PTRPART^,1,I); #I:=I+1; #CHEAT.INTPART:=CHEAT.INTPART+512; "END; !CLOSE*)   PROCEDURE SAVE;  BEGIN !WITH PBCODEINFO DO BEGIN "NAME:=CONCAT(FILENAME,'.BAS'); "STARTADDR:=BASZERPG[104]*256+BASZERPG[103]; "ENDADDR:=BASZERPG[176]*256+BASZERPG[175]; "CODELENG:=ENDADDR-STARTADDR+1; "SAVEFILE(NAME,STARTADDR,CODELENG); .INTPART+512; "END; "CLOSE(UNITFID,LOCK);  END; (*SAVEFILE*)   PROCEDURE BSAVE;  BEGIN !WITH PBCODEINFOR DO BEGIN "NAME:=CONCAT(FILENAME,'.BIN'); "STARTADDR:=BEGINADDR; "CODELENG:=CODELEN; "SAVEFILE(NAME,BEGINADDR,CODELEN); !END;  END; (*BSAVRT:=BEGINADDR; "PBCODEINFO.BASICZERPG:=BASZERPG; "NUMBLKS:=(CODELEN + 511) DIV 512; "REWRITE(UNITFID,FILENAME); "IO:=BLOCKWRITE(UNITFID,PBCODEINFO,1,0); "FOR I:=1 TO NUMBLKS DO BEGIN #IO:=BLOCKWRITE(UNITFID,CHEAT.PTRPART^,1,I); #CHEAT.INTPART:=CHEAT"UNTIL (HEAPINFO>HPSTOP); "  (*MOVE HEAP*) "SOURCE.INTPART:=OLDLOC; "DEST.INTPART:=NEWLOC; "MOVELEFT(SOURCE.PTRPART^,DEST.PTRPART^,LEN);  END; (*MOVEHEAP*)   PROCEDURE SAVEFILE(FILENAME:UNITSTR; 3BEGINADDR,CODELEN:INTEGER);  BEGIN "CHEAT.INTPAWORD(HEAPINFO+I*2); &POKEWORD(HEAPPTR,PEEKWORD(HEAPPTR)+DISPLACEMENT); $END; $ "HEAPPTR:=PEEKWORD(HEAPINFO); (*MORE PTRS*) "REPEAT $POKEWORD(HEAPINFO,HEAPPTR+DISPLACEMENT); $HEAPINFO:=HEAPINFO+2; $HEAPPTR:=PEEKWORD(HEAPINFO); (*MAKE HEAP AS SMALL*) "RELEASE(HEAP); (*AS POSSIBLE*) "LEN:=PEEKWORD(NP)-OLDLOC; "  (*FIX NP (THE TOP OF HEAP) *) "POKEWORD(NP,PEEKWORD(NP)+DISPLACEMENT); "  (*CHANGE POINTERS*) "FOR I:=0 TO 2 DO (*SYSTEM HEAP PTRS*) $BEGIN &HEAPPTR:=PEEK* TOP OF HEAP *) &  VAR HEAPINFO,HPSTOP,HEAPPTR,LEN, $DISPLACEMENT:INTEGER; $HEAP:^INTEGER; $  BEGIN "HEAPINFO:=PEEKWORD(98)+14; "HPSTOP:=HEAPINFO+112; "DISPLACEMENT:=NEWLOC-OLDLOC; "HIMEM:=NEWLOC; "  (*DETERMINE LENGTH OF HEAP*) "MARK(HEAP); "BEGIN #CODELENG:=0;CODEADDR:=1; #FILLCHAR(NAME,25,' '); #STARTADDR:=0; #FOR I:=0 TO 255 DO BASICZERPG[I]:=0; #FOR I:=0 TO 71 DO FILLER[I]:=0; #COMMENT:='P+B BY RON DEGROAT 2/81'; "END;  END; (*INITPB*)   BEGIN (*MAIN PROGRAM*) !DOSLOADED:=FALSE; !HIMEM:=3072; (* $C00, BOTTOM OF HEAP*) !INITPBCODEINFO; INITBASZERPG; !IF FPBASIC THEN BEGIN "RUNADDR:=-10906; (* $D566 *) "HIMEMADDR:=115; (* $73-74*) !END "ELSE BEGIN #RUNADDR:=-4116; (* $EFEC *) #HIMEMADDR:=76; (* $4C-4D*SET (PLA (PLA (PLA (LDY #00 (LDA 0E000 ;CHECK FOR INT OR FP (CMP #04C (BNE FALSE ;BRANCH IF INT BASIC (INY  FALSE TYA ;LSB = 1 IF FP (PHA ;LSB = 0 IF INT (PHA (PUSH RETPAS (STA 0C088 ;SELECT RAM (RTS  ( (.PROC ROMCALL,1SETNORM (JSR INIT (JSR SETVID (JSR SETKBD (LOAD FPCHRGET,CHRGET,01C (RTS  ( (.FUNC FPBASIC   ;IF APPLESOFT IN ROM, FPBASIC = TRUE ( (.REF RETPAS ( (STA 0C08A ;ENABLE ROM (POP RETPAS ;SAVE PASCAL RET ADDR (PLA ;DISCARD OFF SCR2 .EQU 0DBA6 ;0D9CB FOR VER II.1  ( (.PROC INITBASZERPG ( (.REF ZERTEMP,STKTEMP  (LOAD ZERPAG,ZERTEMP,000 (LOAD STKTEMP,ZERPAG,000 ;ZERO IT (RCALL INITZPG (LOAD ZERPAG,BASZERPG,000 (LOAD ZERTEMP,ZERPAG,000 (RTS  INITZPG JSR  INIT .EQU 0FB2F  SETVID .EQU 0FE93  SETKBD .EQU 0FE89  FPCHRGET.EQU 0F10A  CHRGET .EQU 0B0   MONVEC .EQU 03F0  ZERPAG .EQU 0000  STK .EQU 0100  DBUF .EQU 03A0 ;DISK INFO   MAXCOL .EQU 0DB7C ;0D9B9 FOR VER II.1 0C088 ;RE-ENABLE RAM (.ENDM (  ;LOAD DATA OR ROUTINE (NO MORE THAN 256 BYTES) ( (.MACRO LOAD ;FORMAT: (LDY #00 ;LOAD SOURCE,DEST,LEN  $1 LDA %1,Y (STA %2,Y (INY (CPY #%3 (BNE $1 (.ENDM ( (.PUBLIC BASZERPG (  SETNORM .EQU 0FE84(PLA (STA %1 (PLA (STA %1+1 (.ENDM   ;PUSH ADDR ONTO STACK ( (.MACRO PUSH ;FORMAT: PUSH ADDR (LDA %1+1 (PHA (LDA %1 (PHA (.ENDM   ;CALL TO ROM SUBROUTINE ( (.MACRO RCALL ;FORMAT: RCALL ADDRESS (STA 0C08A ;ENABLE ROM (JSR %1 (STA  ;-----------------------------------------------  ;LISTING #3: PBPROC, ROUTINES USED BY BASICSTUFF  ;  ;WRITTEN BY RON DEGROAT 3/81  ;-----------------------------------------------   ;POP ADDR FROM STACK ( (.MACRO POP ;FORMAT: POP ADDR vgOPCODESr=vg NITEDRIVER  CALL.TEXTtM{ CALL.CODEmBELLr CHARr DOS.3.3r  RCALL.TEXTM{2MUSICr 2 PBASIC.TE}N3PLE2 RCALL.CODE F2N3PLE12& SYSTEM.APPLEvg&O SYSTEM.PASCALvgiOPSYSTEM.MISCINFOEP SYSTEM.EDITORvg SYSTEM.FILERvg)SYSTEM.LIBRARYg MUD.OPCODESB END A C  O3 N^) "END;  END. (*CHANGE '.' TO ';' FOR COMBINED *) &(*UNIT/HOST COMPILATION. *)    ;SWAP ZERO PGS, SAVE PASCAL STUFF, ENABLE ROMS  ;THEN JSR AND RESTORE EVERYTHING ON RETURN ( (.DEF ZERTEMP,STKTEMP,DEST,RETPAS (.DEF SOFTEV,PWREDUP   LOAD ZERPAG,ZERTEMP,000 (LOAD BASZERPG,ZERPAG,000 (LOAD DBUF,BUFTEMP,012  (LOAD MVEC,MONVEC,010 (LOAD RETJMP,007,003 ( (POP RETPAS ;SAVE PASCAL RETURN (POP DEST ;GET DESTINATION ADDR (RCALL ENTRY ;CALL DEST INDIRECTLY (PUSH RETPAS ;RESTORE PASCAL RETURN (  ;RESTORE DISK INFO, SWAP PASCAL ZERO PG FOR   BEGIN !WRITELN; WRITELN !('INSERT COPY OF DOS 3.3 MASTER DISK'); !WRITELN('INTO THE BOOT DRIVE (#4:)'); !WAITFORCR; !RESET(S,'#4:'); !BLN:=2; !BLT:=BLOCKREAD(S,BLK,1,BLN); !IF (BLK[260]=191) THEN "BLK[260]:=127 #ELSE $WRITELN('CONVERSION NOT *)  (*MASTER DISK SO THAT IT LOADS AS IF *)  (*THE SYSTEM WERE 32K. *)   VAR BLK:PACKED ARRAY[0..511] OF 0..255; $BLT,BLN:INTEGER; $S:FILE; $  PROCEDURE WAITFORCR;  BEGIN !WRITELN('PRESS TO CONTINUE'); !READLN;  END; $  (**********************************)  (* LISTING #4: 32K DOS CONVERSION *)  (* *)  (* WRITTEN BY RON DEGROAT 3/81 *)  (**********************************)   PROGRAM DOS32K;   (*THIS PROGRAM MODIFIES A DOS 3.3 '^XCOL (LDA 0C088 ;SELECT AND PROTECT 3;1ST BANK (RTS ( (.PROC DISPLAY80 ( (LDA 0C083 (LDA 0C083 (LDA #0B0 ;BCS (STA SCR2 (LDA #011 (STA SCR2+1 (LDA #04F ;MAX COLUMN # = 79 (STA MAXCOL (LDA 0C088 (RTS ( (.END ( ( (.PROC CALL,1 ( (.REF RETPAS,DEST  (POP RETPAS (POP DEST (PUSH RETPAS (JMP @DEST  (.PROC DISPLAY40 ( (LDA 0C083 ;WRITE-ENABLE RAM (LDA 0C083 ;ON 2ND BANK (LDA #0EA ;NOP (STA SCR2 (STA SCR2+1 (LDA #27 ;MAX COLUMN # = 39 (STA MA  ZERTEMP .BLOCK 0100  STKTEMP .BLOCK 0100  BUFTEMP .BLOCK 012 ( ( (.PROC DOSRESET ( (.REF SOFTEV,PWREDUP ( (LDA #0BF (STA SOFTEV ;POINT RESET VECTOR (LDA #05D ;TO DOS (STA SOFTEV+1 (LDA #0F8 (STA PWREDUP ;FIX PWR UP BYTE (RTS STORE LOAD STKTEMP,STK,000 (LDX SAVESP (TXS (RTS (  MVEC .WORD 0FA59 ;BRK  SOFTEV .WORD 0E003  PWREDUP .BYTE 045 (JMP 0FF59 ;RESET  RETJMP JMP RESTORE (JMP RESTORE (.WORD 0FF65   DEST .WORD 00  RETPAS .WORD 00  SAVESP .BYTE 00 ;BASIC'S AND MESS PWR UP BYTE  (LOAD BUFTEMP,DBUF,012 (LOAD ZERPAG,BASZERPG,000 (LOAD ZERTEMP,ZERPAG,000 (STY 03F4 ;MESS PWR UP BYTE (RTS (  ;SAVE STACK AND JUMP TO DEST   ENTRY TSX (STX SAVESP (LOAD STK,STKTEMP,000 (JMP @DEST   REPOSSIBLE'); !BLT:=BLOCKWRITE(S,BLK,1,BLN); !WRITELN;WRITELN('RE-INSERT PASCAL DISK'); !WAITFORCR;  END. N^% END;  END;  FUNCTION WORDVAL(LOC: INTEGER): INTEGER; '(*=======*)   VAR "W: WORD;   BEGIN  W.B[0] := BYTEVAL(LOC);  W.B[1] := BYTEVAL(SUCC(LOC));  WORDVAL := W.I;  END;   PROCEDURE HEXBYTE(VALUE: INTEGER; VAR HEX: STRING1); ((*======FILE'); "EXIT(DECODE); "END;  END;   FUNCTION BYTEVAL(LOC: INTEGER): INTEGER; '(*=======*)   BEGIN  IF (LOC >= FIRSTADDR) AND (LOC < FIRSTADDR+512) THEN "BYTEVAL := BUF[LOC-FIRSTADDR]  ELSE "BEGIN "READBLOCK(LOC); "BYTEVAL := BYTEVAL(LOC); ELSE IF LOC >= (FIRSTADDR+512) THEN "REPEAT $CURRENTBLOCK := SUCC(CURRENTBLOCK); $FIRSTADDR := FIRSTADDR+512; ! UNTIL LOC < (FIRSTADDR+512);  IF BLOCKREAD(SOURCEFILE,BUF,1,CURRENTBLOCK) <> 1 THEN  BEGIN "WRITELN('BLOCKREAD: ERROR IN READING SOURCETHEN  PAGE(F)  ELSE "WRITELN(F);  END;   PROCEDURE READBLOCK(LOC: INTEGER); ((*=========*)   BEGIN  IF LOC < FIRSTADDR THEN "REPEAT $CURRENTBLOCK := PRED(CURRENTBLOCK); $FIRSTADDR := FIRSTADDR-512; ! UNTIL LOC >= FIRSTADDR GIT: PACKED ARRAY [0..15] OF CHAR;   PROCEDURE WAIT; ((*====*)   BEGIN  IF DESTNAME = 'CONSOLE:' THEN "BEGIN "WRITELN; "WRITE('[RETURN TO CONTINUE]'); "READLN;  END;  END;  PROCEDURE SKIP; ((*====*)   BEGIN  IF DESTNAME = 'CONSOLE:' "FIRSTBLOCK, "CURRENTBLOCK: INTEGER; "ADDR: STRING3; "F: TEXT; "SOURCEFILE: FILE; "SOURCENAME, "DESTNAME: STRING; "OPCODE: ARRAY [0..255] OF OPREC;  BUF: PACKED ARRAY [0..511] OF 0..255;  SD: FREEUNION; "PD: ARRAY [0..149] OF INTEGER; "HEXDI"STRING1 = PACKED ARRAY [0..1] OF CHAR; "STRING3 = PACKED ARRAY [0..3] OF CHAR; "STRING7 = STRING[7]; "PTYPE = (UB,SB,DB,B,W,X0,X1,X2,X3,X4,X5,X6,X7,XX); "OPREC = RECORD $MNEMONIC: STRING7; $P1, $P2: PTYPE; $END;   VAR "PDCOUNT, "FIRSTADDR, Y [0..15] OF &PACKED RECORD &SEGNUM: 0..255; &MTYPE: MTYPES; &UNUSED: 0..1; &VERSION: 0..7 &END; $(* AND OTHER GOOD STUFF *) $END; "FREEUNION = RECORD $CASE INTEGER OF $1: (BUF: PACKED ARRAY [0..511] OF 0..255); $2: (DICT: SDRECORD); $END; INTEGER &END; $SEGNAME: ARRAY [0..15] OF &PACKED ARRAY [0..7] OF CHAR; $SEGKIND: ARRAY [0..15] OF &(LINKED, HOSTSEG, SEGPROC, UNITSEG, 'SEPRTSEG, UNLINKEDINTRINS, 'LINKEDINTRINS, DATASEG); $TEXTADDR: ARRAY[0..15] OF INTEGER; $SEGINFO: PACKED ARRA2: (H: PACKED ARRAY [0..3] OF 0..15); $3: (I: INTEGER); $4: (P: ^ WORD) $END; "MTYPES = (UNDEF, PCODEMOST, PCODELEAST, PDP11, M8080, $Z80, GA440, M6502, M6800, TI9900); "SDRECORD = RECORD $DISKINFO: ARRAY [0..15] OF &RECORD &CODELENG, &CODEADDR: (*$C COPYRIGHT 1981 BY CHRIS WILSON *)   (* USE COMMAND-LEVEL SWAPPING OPTION TO EDIT & COMPILE *)   PROGRAM DECODE;   TYPE "WORD = PACKED RECORD $CASE INTEGER OF $0: (B: PACKED ARRAY [0..1] OF 0..255); $1: (C: PACKED ARRAY [0..1] OF CHAR); $=*)  VAR  W: WORD;   BEGIN W.I := VALUE;  HEX[0] := HEXDIGIT[W.H[1]];  HEX[1] := HEXDIGIT[W.H[0]];  END;   PROCEDURE HEXWORD(VALUE: INTEGER; VAR HEX: STRING3); ((*=======*)   VAR  W: WORD;   BEGIN W.I := VALUE;  HEX[0] := HEXDIGIT[W.H[3]];  HEX[1] := HEXDIGIT[W.H[2]]; HEX[2] := HEXDIGIT[W.H[1]];  HEX[3] := HEXDIGIT[W.H[0]];  END;  PROCEDURE DECODEPROC(PROC: INTEGER); ((*==========*)   VAR "IPC, "JTAB, "LEXLEVEL, "ENTERIC, "EXITIC, "PARAMSIZE, "DA ' (', HEX, ')'); &END; $END; "X3: $BEGIN $(* EQU, ETC. *) $CASE BYTEVAL(IPC) OF %2: WRITE(F, ' (REAL)'); %4: WRITE(F, ' (STRING)'); %6: WRITE(F, ' (BOOLEAN)'); %8: WRITE(F, ' (SET)'); $10: BEGIN (HANDLEB; (WRITE(F, ' (BYTE ARRAY)'); $ END BE WORD ALIGNED *) &IPC := SUCC(IPC); $HANDLEW; $HANDLEW; $HANDLEW; $MIN := WORDVAL(IPC-5); $MAX := WORDVAL(IPC-3); $FOR I := MIN TO MAX DO &BEGIN &WRITELN(F); &WRITE(F, ' ':19); &HANDLEW; &HEXWORD(PRED(IPC)-WORDVAL(PRED(IPC)),HEX); &WRITE(F,&IF I MOD 16 = 0 THEN (BEGIN (WRITELN(F, ''''); (WRITE(F, ' ':21, ''''); (END; &IF BYTEVAL(IPC) > 31 THEN (WRITE(F, CHR(BYTEVAL(IPC))) &ELSE (WRITE(F, '.'); &END; $WRITE(F, ''''); $END; "X2: $BEGIN $(* XJP *) $IF NOT ODD(IPC) THEN &(* MUST"XX: $BEGIN $END; "END; (* CASE *) "CASE P2 OF "UB, SB, DB: " HANDLEDB; "B: " HANDLEB; "W: " HANDLEW; "X0: " HANDLECSP; "X1: $BEGIN $(* LSA, LSP *) $WRITE(F, ' '''); $FOR I := 1 TO BYTEVAL(IPC) DO &BEGIN &IPC := SUCC(IPC); BEGIN (* ONEOP *)  WITH OPCODE[BYTEVAL(IPC)] DO "BEGIN "HEXWORD(IPC,HEX); "HEXBYTE(BYTEVAL(IPC),BYTE); "WRITE(F, HEX, ' ', MNEMONIC, ' (', BYTE, ')', ' ':7-LENGTH(MNEMONIC)); "CASE P1 OF "UB, SB, DB: " HANDLEDB; "B: $HANDLEB; "W: " HANDLEW; )'; $22: S := ' (WRITELN)'; $23: S := ' (CONCAT)'; $24: S := ' (INSERT)'; $25: S := ' (COPY)'; $26: S := ' (DELETE)'; $27: S := ' (POS)'; $28: S := ' (BLOCK READ/WRITE)'; $29: S := ' (GOTOXY)'; $END; (* CASE *) " WRITE(F, S); $END; "END;   $11: S := ' (EOLN)'; " 12: S := ' (READ INTEGER)'; $13: S := ' (WRITE INTEGER)'; $16: S := ' (READ CHAR)'; $17: S := ' (WRITE CHAR)'; $18: S := ' (READ STRING)'; $19: S := ' (WRITE STRING)'; $20: S := ' (WRITE ARRAY OF CHAR)'; $21: S := ' (READLNANDLEDB; "IF BYTEVAL(PRED(IPC)) = 0 THEN $BEGIN $S := ''; $CASE BYTEVAL(IPC) OF %2: S := ' (EXECERROR)'; %3: S := ' (BUILD FIB)'; %5: S := ' (RESET/REWRITE)'; %6: S := ' (CLOSE)'; %7: S := ' (GET)'; %8: S := ' (PUT)'; $10: S := ' (EOF)'; ESULT)'; "35: S := ' (UNITBUSY)'; "36: S := ' (PWROFTEN)'; "37: S := ' (UNITWAIT)'; "38: S := ' (UNITCLEAR)'; "39: S := ' (HALT)'; "40: S := ' (MEMAVAIL)'; "END; (* CASE *) "WRITE(F, S); "END;   PROCEDURE HANDLECXP; "VAR S: STRING; "BEGIN "H: S := ' (TIME)'; "10: S := ' (FILLCHAR)'; "11: S := ' (SCAN)'; "21: S := ' (LOAD RESIDENT SEGMENT)'; "22: S := ' (UNLOAD RESIDENT SEGMENT)'; "23: S := ' (TRUNC)'; "24: S := ' (ROUND)'; "32: S := ' (MARK)'; "33: S := ' (RELEASE)'; "34: S := ' (IOR"S := ''; "CASE BYTEVAL(IPC) OF #0: S := ' (IOCHECK)'; #1: S := ' (NEW)'; #2: S := ' (MOVELEFT)'; #3: S := ' (MOVERIGHT)'; #4: S := ' (EXIT)'; #5: S := ' (UNITREAD)'; #6: S := ' (UNITWRITE)'; #7: S := ' (IDSEARCH)'; #8: S := ' (TREESEARCH)'; #9TE); $WRITE(F, BYTE:3); $END; "END;   PROCEDURE HANDLEW; "BEGIN "HEXBYTE(BYTEVAL(IPC+2),BYTE); "WRITE(F, BYTE:3); "HEXBYTE(BYTEVAL(IPC+1),BYTE); "WRITE(F, BYTE); "IPC := IPC+2; "END;  PROCEDURE HANDLECSP; "VAR S: STRING; "BEGIN  PROCEDURE HANDLEB; "BEGIN "IPC := SUCC(IPC); "IF BYTEVAL(IPC) > 127 THEN $BEGIN $HEXBYTE(BYTEVAL(IPC)-128,BYTE); $WRITE(F, BYTE:3); $IPC := SUCC(IPC); $HEXBYTE(BYTEVAL(IPC),BYTE); $WRITE(F, BYTE); $END "ELSE $BEGIN $HEXBYTE(BYTEVAL(IPC),BYTASIZE, "LASTCODE: INTEGER; "HEX: STRING3;   PROCEDURE ONEOP; ((*=====*)   VAR "I, "MIN, "MAX: INTEGER; "BYTE: STRING1; "HEX: STRING3;  PROCEDURE HANDLEDB; "BEGIN "IPC := SUCC(IPC); "HEXBYTE(BYTEVAL(IPC),BYTE); "WRITE(F, BYTE:3); "END;; $12: BEGIN (HANDLEB; (WRITE(F, ' (WORD)'); $ END; $END; (* CASE *) $END; "X4: $BEGIN $(* LDC *) $MAX := BYTEVAL(IPC); $IF NOT ODD(IPC) THEN &(* MUST BE WORD ALIGNED *) &IPC := SUCC(IPC); $FOR I := 1 TO MAX DO &BEGIN &WRITELN(F); &WRITE(F, ' ':19); &HANDLEW; &END; $END; "X5: $HANDLECXP; X6: $BEGIN $(* FJP, UJP, EFJ, NFJ *) $I := BYTEVAL(IPC); (* JUMP OFFSET *) $IF I < 128 THEN &HEXWORD(SUCC(IPC)+I,HEX) $ELSE &BEGIN &I := JTAB-(256-I); &HEXWORD(I-WORDVAL(I),HEX); E;  END;   PROCEDURE READSEGDICT; ((*===========*)   VAR "I: INTEGER;  S: STRING;   BEGIN  IF BLOCKREAD(SOURCEFILE,SD.BUF,1,0) <> 1 THEN "BEGIN "WRITELN('ERROR IN READING SEGMENT DICTIONARY'); "EXIT(DECODE); "END;  WITH SD.DICT DO "BET NOT P-CODE (LEAST)'); (IF SEGINFO[I].MTYPE IN [UNDEF,PCODEMOST] THEN *BEGIN *WRITE('TRY TO DECODE ANYWAY (Y/N): '); *READLN(ANSWER); *IF ANSWER IN ['Y','y'] THEN ,READPROCDICT(I); *END (ELSE *WAIT; (END " ELSE (READPROCDICT(I); "UNTIL DON&IF SEGNAME[I] <> ' ' THEN (WRITELN(I:2, ' ', SEGNAME[I]); $WRITELN; $WRITELN('-1 TO EXIT'); $WRITELN; $WRITE('SEGMENT: '); $READLN(I); $DONE := I < 0; $IF I IN [0..15] THEN &IF SEGINFO[I].MTYPE <> PCODELEAST THEN (BEGIN (WRITELN('SEGMEN CHOOSEPROC;  END;   PROCEDURE CHOOSESEGMENT; ((*=============*)   VAR "I: INTEGER;  ANSWER: CHAR; "DONE: BOOLEAN;   BEGIN  WITH SD.DICT DO "REPEAT $PAGE(OUTPUT); $WRITELN('SEGMENT TO ANALYZE:'); $WRITELN; $FOR I := 0 TO 15 DO AL(LOC));  WRITELN(F, 'PROCEDURE COUNT ', PDCOUNT);  WRITELN(F);  FOR I := 1 TO PDCOUNT DO "BEGIN "LOC := LOC-2; "PD[I] := LOC-WORDVAL(LOC); "HEXWORD(PD[I],HEX); "WRITELN(F, 'PROCEDURE ', I:2, ', ADDRESS ', PD[I]:5, ' (', HEX, ')'); "END;  WAIT; := DISKINFO[SEG].CODELENG; "END;  LOC := PRED(SEGLENGTH);  READBLOCK(LOC);  PDCOUNT := BYTEVAL(LOC);  LOC := PRED(LOC);  SKIP;  WRITELN(F, 'PROCEDURE DICTIONARY:');  WRITELN(F, '---------------------');  WRITELN(F);  WRITELN(F, 'SEGMENT ', BYTEV PROCEDURE READPROCDICT(SEG: INTEGER); ((*============*)   VAR "I, "LOC, "SEGLENGTH: INTEGER; "HEX: STRING3;   BEGIN  WITH SD.DICT DO "BEGIN "FIRSTADDR := 0; "FIRSTBLOCK := DISKINFO[SEG].CODEADDR;  CURRENTBLOCK := FIRSTBLOCK; "SEGLENGTHDE:'); "WRITELN; "WRITELN('[1..', PDCOUNT, ']'); "WRITELN; "WRITELN; "WRITELN('-1 TO EXIT'); "WRITELN; "WRITE('PROCEDURE: '); "READLN(I); "DONE := I < 0; "IF I IN [1..PDCOUNT] THEN $DECODEPROC(I);  UNTIL DONE;  END;  IC BAD <<<') "ELSE $REPEAT &ONEOP; &IPC := SUCC(IPC); $UNTIL IPC > LASTCODE;  END;  WAIT;  END;   PROCEDURE CHOOSEPROC; ((*==========*)   VAR "I: INTEGER;  DONE: BOOLEAN;   BEGIN  REPEAT "PAGE(OUTPUT); "WRITELN('PROCEDURE TO DECOX); "WRITELN(F, 'DATA SIZE ', DATASIZE, ' (', HEX, ')'); "WRITELN(F); "IPC := ENTERIC; "IF LEXLEVEL < -1 THEN $WRITELN('>>> LEX LEVEL BAD <<<') "ELSE IF ENTERIC < 0 THEN $WRITELN('>>> ENTER IC BAD <<<') "ELSE IF EXITIC < 0 THEN $WRITELN('>>> EXIT "HEXWORD(ENTERIC,HEX); "WRITELN(F, 'ENTER IC ', ENTERIC, ' (', HEX, ')'); "HEXWORD(EXITIC,HEX); "WRITELN(F, 'EXIT IC ', EXITIC, ' (', HEX, ')'); "HEXWORD(PARAMSIZE,HEX); "WRITELN(F, 'PARAMETER SIZE ', PARAMSIZE, ' (', HEX, ')'); "HEXWORD(DATASIZE,HETAB-4); "PARAMSIZE := WORDVAL(JTAB-6); "DATASIZE := WORDVAL(JTAB-8); "LASTCODE := JTAB-9; "SKIP; "WRITELN(F, 'PROCEDURE CODE:'); "WRITELN(F, '---------------'); "WRITELN(F); "WRITELN(F, 'LEX LEVEL ', LEXLEVEL, ', PROCEDURE ', BYTEVAL(JTAB)); TAB < 0 THEN "BEGIN "WRITELN; "WRITELN('>>> PROCEDURE ADDRESS BAD <<<');  END  ELSE "BEGIN "LEXLEVEL := BYTEVAL(SUCC(JTAB)); "IF LEXLEVEL > 127 THEN $LEXLEVEL := LEXLEVEL-256; "ENTERIC := (JTAB-2)-WORDVAL(JTAB-2); "EXITIC := (JTAB-4)-WORDVAL(J&END; $WRITE(F, ' (', HEX, ')'); $END; "X7: $BEGIN $(* RNP, RBP *) $IF IPC >= EXITIC THEN &LASTCODE := IPC; $END; "XX: $BEGIN $END; "END; (* CASE *)  END; (* WITH *)  WRITELN(F);  END;   BEGIN (* DECODEPROC *)  JTAB := PD[PROC];  IF JGIN "I := 0; "SKIP; "WRITELN(F, 'SEGMENT DICTIONARY:'); "WRITELN(F, '-------------------'); "REPEAT $IF SEGNAME[I] <> ' ' THEN &WITH SEGINFO[I] DO (BEGIN (WRITELN(F); (WRITELN(F, 'SEGMENT #', SEGNUM); (WITH DISKINFO[I] DO *WRITELN(F, 'LENGTH ', CODELENG, ', ADDRESS ', CODEADDR); (WRITELN(F, 'SYSTEM VERSION = ', VERSION); (S := ''; (CASE MTYPE OF (UNDEF: *S := 'UNDEFINED'; (PCODEMOST: *S := 'P-CODE (MOST SIG. 1ST)'; (PCODELEAST: *S := 'P-CODE (LEAST SIG. 1ST)'; (P,XX,XX); (* BB *) "INIT(188,'LDM' ,UB,XX); (* BC *) "INIT(189,'STM' ,UB,XX); (* BD *) "INIT(190,'LDB' ,XX,XX); (* BE *) "INIT(191,'STB' ,XX,XX); (* BF *) "INIT(192,'IXP' ,UB,UB); (* C0 *) "INIT(193,'RBP' ,DB,X7); (* C1 *) "INIT(19(* B4 *) "INIT(181,'LES' ,DB,X3); (* B5 *) "INIT(182,'LOD' ,DB, B); (* B6 *) "INIT(183,'NEQ' ,DB,X3); (* B7 *) "INIT(184,'STR' ,DB, B); (* B8 *) "INIT(185,'UJP' ,SB,X6); (* B9 *) "INIT(186,'LDP' ,XX,XX); (* BA *) "INIT(187,'STP' "INIT(175,'EQU' ,DB,X3); (* AF *) "END; "  PROCEDURE INIT2; "BEGIN "INIT(176,'GEQ' ,DB,X3); (* B0 *) "INIT(177,'GRT' ,DB,X3); (* B1 *) "INIT(178,'LDA' ,DB, B); (* B2 *) "INIT(179,'LDC' ,UB,X4); (* B3 *) "INIT(180,'LEQ' ,DB,X3); 69,'LDO' , B,XX); (* A9 *) "INIT(170,'SAS' ,UB,XX); (* AA *) "INIT(171,'SRO' , B,XX); (* AB *) "INIT(172,'XJP' ,XX,X2); (* AC *) "INIT(173,'RNP' ,DB,X7); (* AD *) "INIT(174,'CIP' ,UB,XX); (* AE *) , B,XX); (* A2 *) "INIT(163,'IND' , B,XX); (* A3 *) "INIT(164,'IXA' , B,XX); (* A4 *) "INIT(165,'LAO' , B,XX); (* A5 *) "INIT(166,'LSA' ,UB,X1); (* A6 *) "INIT(167,'LAE' ,UB, B); (* A7 *) "INIT(168,'MOV' , B,XX); (* A8 *) "INIT(1 (* 9B *) "INIT(156,'UNI' ,XX,XX); (* 9C *) "INIT(157,'LDE' ,UB, B); (* 9D *) "INIT(158,'CSP' ,UB,X0); (* 9E *) "INIT(159,'LDCN' ,XX,XX); (* 9F *) "INIT(160,'ADJ' ,UB,XX); (* A0 *) "INIT(161,'FJP' ,SB,X6); (* A1 *) "INIT(162,'INC' "INIT(149,'SBI' ,XX,XX); (* 95 *) "INIT(150,'SBR' ,XX,XX); (* 96 *) "INIT(151,'SGS' ,XX,XX); (* 97 *) "INIT(152,'SQI' ,XX,XX); (* 98 *) "INIT(153,'SQR' ,XX,XX); (* 99 *) "INIT(154,'STO' ,XX,XX); (* 9A *) "INIT(155,'IXS' ,XX,XX); 8E *) "INIT(143,'MPI' ,XX,XX); (* 8F *) "INIT(144,'MPR' ,XX,XX); (* 90 *) "INIT(145,'NGI' ,XX,XX); (* 91 *) "INIT(146,'NGR' ,XX,XX); (* 92 *) "INIT(147,'LNOT' ,XX,XX); (* 93 *) "INIT(148,'SRS' ,XX,XX); (* 94 *) IT(136,'CHK' ,XX,XX); (* 88 *) "INIT(137,'FLO' ,XX,XX); (* 89 *) "INIT(138,'FLT' ,XX,XX); (* 8A *) "INIT(139,'INN' ,XX,XX); (* 8B *) "INIT(140,'INT' ,XX,XX); (* 8C *) "INIT(141,'LOR' ,XX,XX); (* 8D *) "INIT(142,'MODI' ,XX,XX); (* R' ,XX,XX); (* 81 *) "INIT(130,'ADI' ,XX,XX); (* 82 *) "INIT(131,'ADR' ,XX,XX); (* 83 *) "INIT(132,'LAND' ,XX,XX); (* 84 *) "INIT(133,'DIF' ,XX,XX); (* 85 *) "INIT(134,'DVI' ,XX,XX); (* 86 *) "INIT(135,'DVR' ,XX,XX); (* 87 *) "IN S: STRING7;   PROCEDURE INIT(OP: INTEGER; MNE:STRING7; X1, X2: PTYPE); "BEGIN "WITH OPCODE[OP] DO $BEGIN $MNEMONIC := MNE; $P1 := X1; $P2 := X2; $END; "END; "  PROCEDURE INIT1; "BEGIN  INIT(128,'ABI' ,XX,XX); (* 80 *) "INIT(129,'ABC'; (DATASEG: *S := 'DATA SEGMENT'; (END; (* CASE *) (WRITELN(F, SEGNAME[I], ' (', S, ')'); (END; $I := SUCC(I); "UNTIL I > 15;  END;  WAIT;  CHOOSESEGMENT;  END;   PROCEDURE INITIALIZE; ((*==========*)   VAR "I: INTEGER; KED: *S := 'LINKED'; (HOSTSEG: *S := 'HOST SEGMENT'; (SEGPROC: *S := 'SEGMENT PROCEDURE'; (UNITSEG: *S := 'UNIT SEGMENT'; (SEPRTSEG: *S := 'SEPARATE SEGMENT'; (UNLINKEDINTRINS: *S := 'UNLINKED INTRINSIC'; (LINKEDINTRINS: *S := 'LINKED INTRINSIDP11: *S := 'PDP11'; (M8080: *S := '8080'; (Z80: *S := 'Z80'; (GA440: *S := 'GA440'; (M6502: *S := '6502'; (M6800: *S := '6800'; (TI9900: *S := 'TI9900'; (END; (* CASE *) (WRITELN(F, 'CODE TYPE IS ', S); (S := ''; (CASE SEGKIND[I] OF (LIN4,'CBP' ,UB,XX); (* C2 *) "INIT(195,'EQUI' ,XX,XX); (* C3 *) "INIT(196,'GEQI' ,XX,XX); (* C4 *) "INIT(197,'GRTI' ,XX,XX); (* C5 *) "INIT(198,'LLA' , B,XX); (* C6 *) "INIT(199,'LDCI' , W,XX); (* C7 *) "INIT(200,'LEQI' ,XX,XX); (* C8 *) "INIT(201,'LESI' ,XX,XX); (* C9 *) "INIT(202,'LDL' , B,XX); (* CA *) "INIT(203,'NEQI' ,XX,XX); (* CB *) "INIT(204,'STL' , B,XX); (* CC *) "INIT(205,'CXP' ,UB,X5); (* CD *) "INIT(206,'CLP' ,UB,XX); RCEFILE,SOURCENAME);  REWRITE(F,DESTNAME);  READSEGDICT;  CLOSE(F,LOCK);  END.  DESTNAME := 'CONSOLE:'  ELSE IF POS('.TEXT',DESTNAME) = 0 THEN "IF DESTNAME[LENGTH(DESTNAME)] <> ':' THEN $IF DESTNAME[LENGTH(DESTNAME)] <> '.' THEN &DESTNAME := CONCAT(DESTNAME,'.TEXT')  ELSE &DELETE(DESTNAME,LENGTH(DESTNAME),1);  RESET(SOU = 0 THEN $IF SOURCENAME[LENGTH(SOURCENAME)] <> '.' THEN &SOURCENAME := CONCAT(SOURCENAME,'.CODE')  ELSE &DELETE(SOURCENAME,LENGTH(SOURCENAME),1);  WRITE('DESTINATION FILE: ');  READLN(DESTNAME);  IF DESTNAME = '' THEN PYRIGHT 1981 BY CHRIS WILSON');  WRITELN;  WRITELN('INITIALIZING...');  INITIALIZE;  WRITELN;  WRITE('SOURCE FILE: ');  READLN(SOURCENAME);  IF SOURCENAME = '' THEN "EXIT(DECODE);  IF POS('.CODE',SOURCENAME) = 0 THEN "IF POS('SYSTEM.',SOURCENAME)N "STR(I,S); "S := CONCAT('SLDC',S); "INIT(I,S,XX,XX); "END;  INIT1;  INIT2;  INIT3;  END;   (* ========== MAIN BODY ========== *)   BEGIN  HEXDIGIT := '0123456789ABCDEF';  PAGE(OUTPUT);  WRITELN('DECODE (6/25/81, 7:48 PM)');  WRITELN('CO"INIT(251,'SIND3' ,XX,XX); (* FB *) "INIT(252,'SIND4' ,XX,XX); (* FC *) "INIT(253,'SIND5' ,XX,XX); (* FD *) "INIT(254,'SIND6' ,XX,XX); (* FE *) "INIT(255,'SIND7' ,XX,XX); (* FF *) "END;   BEGIN (* INITIALIZE *)  FOR I := 0 TO 127 DO  BEGI45,'SLDO14',XX,XX); (* F5 *) "INIT(246,'SLDO15',XX,XX); (* F6 *) "INIT(247,'SLDO16',XX,XX); (* F7 *) "INIT(248,'SIND0' ,XX,XX); (* F8 *) "INIT(249,'SIND1' ,XX,XX); (* F9 *) "INIT(250,'SIND2' ,XX,XX); (* FA *) ,XX,XX); (* EE *) "INIT(239,'SLDO8' ,XX,XX); (* EF *) "INIT(240,'SLDO9' ,XX,XX); (* F0 *) "INIT(241,'SLDO10',XX,XX); (* F1 *) "INIT(242,'SLDO11',XX,XX); (* F2 *) "INIT(243,'SLDO12',XX,XX); (* F3 *) "INIT(244,'SLDO13',XX,XX); (* F4 *) "INIT(2 (* E7 *) "INIT(232,'SLDO1' ,XX,XX); (* E8 *) "INIT(233,'SLDO2' ,XX,XX); (* E9 *) "INIT(234,'SLDO3' ,XX,XX); (* EA *) "INIT(235,'SLDO4' ,XX,XX); (* EB *) "INIT(236,'SLDO5' ,XX,XX); (* EC *) "INIT(237,'SLDO6' ,XX,XX); (* ED *) "INIT(238,'SLDO7'"INIT(225,'SLDL10',XX,XX); (* E1 *) "INIT(226,'SLDL11',XX,XX); (* E2 *) "INIT(227,'SLDL12',XX,XX); (* E3 *) "INIT(228,'SLDL13',XX,XX); (* E4 *) "INIT(229,'SLDL14',XX,XX); (* E5 *) "INIT(230,'SLDL15',XX,XX); (* E6 *) "INIT(231,'SLDL16',XX,XX); 9,'SLDL4' ,XX,XX); (* DB *) "INIT(220,'SLDL5' ,XX,XX); (* DC *) "INIT(221,'SLDL6' ,XX,XX); (* DD *) "INIT(222,'SLDL7' ,XX,XX); (* DE *) "INIT(223,'SLDL8' ,XX,XX); (* DF *) "INIT(224,'SLDL9' ,XX,XX); (* E0 *) , B,XX); (* D5 *) "INIT(214,'XIT' ,XX,XX); (* D6 *) "INIT(215,'NOP' ,XX,XX); (* D7 *) "END;   PROCEDURE INIT3; "BEGIN "INIT(216,'SLDL1' ,XX,XX); (* D8 *) "INIT(217,'SLDL2' ,XX,XX); (* D9 *) "INIT(218,'SLDL3' ,XX,XX); (* DA *) "INIT(21 (* CE *) "INIT(207,'CGP' ,UB,XX); (* CF *) "INIT(208,'LPA' ,UB,X1); (* D0 *) "INIT(209,'STE' ,UB, B); (* D1 *) "INIT(210,'NOP' ,XX,XX); (* D2 *) "INIT(211,'EFJ' ,SB,X6); (* D3 *) "INIT(212,'NFJ' ,SB,X6); (* D4 *) "INIT(213,'BPT' O^SUO,' Regular UNIT '); *SEPRTSEG : WRITE(O,' Seperate procedure'); *UNLINKED_INTRINS : WRITE(O,' Unlinked INTRINSIC'); *LINKED_INTRINS : WRITE(O,' Linked INTRINSIC '); *DATASEG : WRITE(O,' DATA segment '); 'END; (* OF CASE IC DO $BEGIN 'WRITE(O,' ',I:4,' ',SEGNAME[I]); 'CASE SEGKIND[I] OF *LINKED : WRITE(O,' Linked executable '); *HOSTSEG : WRITE(O,' Unlinked Host '); *SEGPROC : WRITE(O,' Segment procedure '); *UNITSEG : WRITE(,' Len Slot Intrf Type Revision '); "WRITELN(O,'________________________________________', " '_______________________________________');  END;   PROCEDURE MAP;  VAR I: INTEGER; J: SEGRANGE;   PROCEDURE MAP1;  BEGIN !WITH SEGDGTH(OFNAME) = 0 THEN OFNAME:='CONSOLE:'; "REWRITE(O,OFNAME); "IF IORESULT<>0 THEN $ERROR('opening output file');  PAGE(O); "WRITELN(O,'------- Code Map for ',FCFNAME,' -------'); "WRITELN(O,' Seg # Name Segment Kind Addr ', ; "IF IORESULT<>0 THEN $ERROR('opening code file'); "IF BLOCKREAD(F,SEGDIC,1,0) <> 1 THEN $ERROR('reading the segment dictionary'); "WRITELN('Output file Name '); "WRITE(' for CONSOLE: ===>'); "CLOSE(O); "OFNAME :=''; "READLN(OFNAME); "IF LENGIN "WRITELN; "WRITELN('==>ERROR ',MESSAGE); "WRITE (' RETURN to abort:'); "READLN; "EXIT(CODEMAP)  END;   PROCEDURE INIT; "VAR FCFNAME,OFNAME:STRING;  BEGIN "CLOSE(F); "WRITE('Code file Name ===>'); "READLN(FCFNAME); "RESET(F,FCFNAME)"O:INTERACTIVE; "SEGNOTREQ:BOOLEAN;   FUNCTION YESNO:BOOLEAN; "VAR CH:CHAR;  BEGIN "REPEAT $WRITE(' Y(es or N(o:'); $READ(CH); $WRITELN "UNTIL CH IN['Y','N','y','n']; "YESNO:= CH IN['Y','y'];  END;   PROCEDURE ERROR(MESSAGE:STRING);  BER; 1SEGINFO:ARRAY[SEGDICRANGE] OF LPACKED RECORD NSEGNO:0..255; NMACHTYPE:MTYPES; NFILLER:0..1; NMAJORREVISION:REVISIONS; LEND; 1INTSEGSET:SEGSET; 1FILLER2:ARRAY[0..109] OF INTEGER /END (* SEGDICREC *);  VAR "SEGDIC:SEGDICREC; "F:FILE; OF CODELENG, CODEADDR:INTEGER  Another Code File ? '); #UNTIL NOT YESNO; ! CLOSE(O,LOCK); !END. -  OR J := 0 TO MAXSEG DO &BEGIN (IF J IN INTSEGSET THEN (BEGIN *WRITE(O,J:3); *SEGNOTREQ:=FALSE; (END; &END; %IF SEGNOTREQ THEN WRITE(O,' None'); $END; ! WRITELN(O); !END; ! !BEGIN #REPEAT %INIT; %MAP; TE(O,' 1.1 '); (END; (* OF CASE *) %END; (* WITH SEGDIC *) #END; (* MAP2 *) *  BEGIN "FOR I:= 0 TO MAXSLOT DO $BEGIN 'MAP1; 'MAP2; 'WRITELN(O); $END; "WRITE(O,'Intrinsic Segments required: '); "SEGNOTREQ:=TRUE; "WITH SEGDIC DO $BEGIN %F); *M6502 :WRITE(O,' 6502 '); *M6800 :WRITE(O,' 6800 '); *TI990 :WRITE(O,' TI990 '); (END; (* OF CASE *) (CASE SEGINFO[I].MAJORREVISION OF *NONAPPLE : WRITE(O,'Non-Apple'); *ONEZERO : WRITE(O,' 1.0 '); *ONEONE : WRIBEGIN  IF HEX IN ['A'..'F'] THEN "CONV := 10+(ORD(HEX)-ORD('A'))  ELSE IF HEX IN ['0'..'9'] THEN "CONV := ORD(HEX)-ORD('0')  ELSE "CONV := 0;  END;   PROCEDURE FIX(BLK, BYTE: INTEGER; OLD, NEW: HEXSTRING);   VAR "IOLD, "INEW: INTEGER;   BEGIN  IOLD := CONV(OLD[2])+(CONV(OLD[1])*16);  INEW := CONV(NEW[2])+(CONV(NEW[1])*16);  IF B[BLK,BYTE] = IOLD THEN "B[BLK,BYTE] := INEW  ELSE "BEGIN "WRITELN('Byte at block ',BLK,' offset ',BYTE); "WRITELN('is ',B[BLK,BYTE],', should be ',IOLD);); !BEGIN "writeln; "writeln('IO ERROR ',ioerror); "writeln('EXITING TRANSFER'); "(*$I-*) #close(pasfile,purge); "(*$I+*) "exit(transfer); !END; ! !FUNCTION openfile(name:pid;VAR f:ffile;VAR ioerror:INTEGER):BOOLEAN; !BEGIN "(*$I-*) "rewrite(!pasfile :ffile; !primpage, !sparepage :pagebuffer; !pagepntr, !sparepntr :pagerange; !relblock :INTEGER; !filetype :pasfilekinds;  fotoflag :BOOLEAN; (* flag for shifts of size 'binaryoffset' *)  !PROCEDURE abortxfer(ioerror:INTEGERPROCEDURE transfer;  TYPE !ffile=FILE;  VAR !dosname :did; !pasname :pid; !suffix :sid; !dirindex :dirrange; !linkindex :linkrange; !nextlink, !nextnode :link; !nextsector :sectbuffer; !currentnode:tslist; !ioerror :INTEGER; $1 $2 O^uLOSE(F,LOCK);  WRITE('Update another disk (y/n): '); "READ(CH); "WRITELN  UNTIL (CH <> 'Y') AND (CH <> 'y');  END.  FIX(15,384,'B9','D7');  FIX(15,385,'F6','D7');  REPEAT "PAGE(OUTPUT); "WRITELN('Insert disk to be modified in unit 4'); "WRITE('Type to continue'); "READ(KEYBOARD,CH); "WRITELN; "RESET(F,'#4:SYSTEM.PASCAL'); "I := BLOCKWRITE(F,B,41); "C; FIX(15,374,'E8','16');  FIX(15,375,'D8','01');  FIX(15,376,'C8','00');  FIX(15,377,'A1','00');  FIX(15,378,'07','C2'); FIX(15,379,'E8','28');  FIX(15,380,'01','CC');  FIX(15,381,'82','01');  FIX(15,382,'AB','D7');  FIX(15,383,'01','D7'); RITE('Type to continue');  READ(KEYBOARD,CH);  WRITELN;  RESET(F,'#4:SYSTEM.PASCAL');  I := BLOCKREAD(F,B,41);  CLOSE(F); FIX(15,369,'C7','B6');  FIX(15,370,'A0','02');  FIX(15,371,'0F','03');  FIX(15,372,'CC','CD');  FIX(15,373,'01','00')  EXIT(PATCHOS); "END;  END;   BEGIN  PAGE(OUTPUT);  WRITELN('Patchos (15-Feb-81, 9:26 pm)');  WRITELN;  WRITELN('Copyright (c) 1982 by Chris Wilson');  WRITELN;  WRITELN('Insert disk with original SYSTEM.PASCAL');  WRITELN('in unit 4');  Wf,name); "ioerror:=ioresult; "(*$I+*) "openfile:=ioerror=0; !END;  !FUNCTION eolist(next:link):BOOLEAN; !BEGIN "WITH next DO #eolist:=((tracknum=0) AND (sectnum=0)); !END; ! !FUNCTION get_node(location:link;VAR listdata:tslist):BOOLEAN; !CONST "contoffset= 1; (* beginning of continuation link *) "contleng = 2; (* length of continuation info *) "listoffset= 12; (* beginning of list of track sector links *) "listleng =244; (* length of list data *) !VAR "sb:sectbuffer; "i:linkra%IF ((pagepntr+sectsize) <= pagesize) (* i.e., enough room for a sector *) &THEN BEGIN ,moveleft(s,primpage[pagepntr+1],sectsize); ,pagepntr:=pagepntr+sectsize; +END &ELSE BEGIN ,(* move as much as possible into the primary page *) ,moveleft(s,primt foto sector *) $THEN BEGIN *moveleft(s[fotoffset],primpage,sectsize-fotoffset); *pagepntr:=sectsize-fotoffset; *fotoflag:=FALSE; )END $ELSE BEGIN %moveleft(sparepage,primpage[pagepntr+1],sparepntr); %pagepntr:=sparepntr+pagepntr; %sparepntr:=0; #moveleft(sparepage[lagindex+1],sparepage,sparepntr-lagindex); #sparepntr:=sparepntr-lagindex; # "END;(* stufftext *) ! "PROCEDURE stuffoto; "CONST #fotoffset=4; (* four bytes of DOS address junk in the first sector *) "BEGIN #IF fotoflag (* firsull:=TRUE %ELSE BEGIN &moveleft(sparepage[lagindex+1],primpage[pagepntr+1],leadindex+1); &pagepntr:=pagepntr+leadindex+1; &lagindex:=lagindex+leadindex+1; &endofspare:=(lagindex=sparepntr); %END; # END; # #IF primfull THEN pagepntr:=pagesize; 0; #cr:=chr(asciicr); # #WHILE NOT (endofspare OR primfull) DO BEGIN $leadindex:=scan((sparepntr-lagindex),=cr,sparepage[lagindex+1]); # IF (leadindex=(sparepntr-lagindex)) THEN endofspare:=TRUE %ELSE IF ((leadindex+pagepntr+1) > pagesize) THEN primfs[nextnull+1],s[nextnull],lengindex-nextnull-1); %lengindex:=lengindex-1; %nextnull:=scan(lengindex,=null,s); $END; " #moveleft(s,sparepage[sparepntr+1],lengindex); #sparepntr:=sparepntr+lengindex; #endofspare:=FALSE; #primfull:=FALSE; #lagindex:=%IF NOT (s[lengindex] IN [space..tilde,asciicr]) THEN s[lengindex]:=0; $END; # #(* squeeze out the middle null characters *) #null:=chr(0); #lengindex:=sectsize; #nextnull:=scan(lengindex,=null,s); #WHILE (nextnull0) THEN (* note: pagepntr to continTSL link':10); !END; ! !PROCEDURE displaydir; !CONST "cleos=11; ! esc=27; "maxlines=21; !VAR "cumsectors:INTEGER; "count:dirrange; ( !BEGIN ! page(output); "gotoxy(0,1); "cumsectors:=0; "IF dosdir[0].dnumentries=0 THEN writeln('The working $write(sectorcount:9); $writeln(filetsl.tracknum:6,'-',filetsl.sectnum:3); #END; !END; ! !PROCEDURE displayheader; !BEGIN "write('File Name'); "write('Type':((didleng-length('file name'))+7)); "write('Locked':8); "write('Sectors':9); "writeln('rite(name,' ':(didleng-length(name)+1)); $CASE dfkind OF %dftext:write('text':6); %dfinteger:write('int':6); %applesoft:write('soft':6); %binary:write('bnry':6); %unknown:write('unkn':6); %END; $IF locked THEN write('yes':8) %ELSE write('no':8); command(VAR ch:CHAR); !BEGIN "read(keyboard,ch); "WHILE NOT(ch IN ['C','c','D','d','T','t','Q','q']) DO #BEGIN $write(chr(7)); $read(keyboard,ch); #END; ! writeln; !END; ! !PROCEDURE displayentry(de:dosdirentry); !BEGIN "WITH de DO #BEGIN $w'.FOTO';filetype:=fotofile; END; #'D','d':BEGIN suffix:='';filetype:=untyped; END; "END; !END; ! !PROCEDURE printmenu; !CONST "cleoln=29; !BEGIN "gotoxy(0,0); "write(chr(cleoln),'C)atalog, D)isplay, T)ransfer, Q)uit?'); !END; ! !PROCEDURE read"writeln; "write('>> '); ! read(keyboard,ch); "WHILE NOT (ch IN ['t','f','d','T','F','D']) DO " BEGIN write(chr(7));read(keyboard,ch); END; ! writeln(ch); ! CASE ch OF #'T','t':BEGIN suffix:='.TEXT';filetype:=textfile; END; #'F','f':BEGIN suffix:=IN $capitalize(name); $getdosid:=TRUE; ! END; !END; " !PROCEDURE getfiletype(VAR suffix:sid;VAR filetype:pasfilekinds); !BEGIN "writeln; "writeln('Transfer to a:'); "writeln; "writeln('T)ext file, F)oto file, or D)ata (binary) file?'); ! !FUNCTION getdosid(VAR name:did):BOOLEAN; !BEGIN "writeln; "writeln('Enter the name of the DOS file to transfer,'); "writeln('or enter to exit:'); "writeln; "write('>>'); "readln(name); "IF (length(name)=0) THEN getdosid:=FALSE #ELSE BEGeln; "writeln('Enter the name of the Pascal destination file,'); "writeln('or enter to exit:'); "writeln; "write('>>'); "readln(name); "IF (length(name)=0) THEN getpasid:=FALSE #ELSE BEGIN $capitalize(name); $getpasid:=TRUE; ! END; !END;  shiftcase=32; !VAR "index:0..maxbyte; !BEGIN "FOR index:=1 TO length(line) DO #IF line[index] IN [chr(ordsmla)..chr(ordsmlz)] # THEN line[index]:=chr(ord(line[index])-shiftcase); !END; ! !FUNCTION getpasid(VAR name:pid):BOOLEAN; !BEGIN "writteln; #write('>> '); #un:=stoi; #IF NOT (un IN [0,4,5,9..12]) THEN writeln(chr(7)); "UNTIL un IN [0,4,5,9..12]; "unitnum:=un; "get_unit_num:=(un<>0); !END;  !PROCEDURE capitalize(VAR line:STRING); !CONST "ordsmla=97; "ordsmlz=122; !FUNCTION get_unit_num(VAR unitnum:unitrange):BOOLEAN; !VAR "un:INTEGER; !BEGIN "REPEAT #writeln; #writeln('Enter the unitnum number [4,5,9..12] of the disk drive containing'); #writeln('the DOS diskette to be cataloged. Enter 0 to escape.'); #wrid THEN index:=index+1; "searchdir:=found; !END; ! !FUNCTION stoi:INTEGER; !VAR "ch:CHAR; ! x:INTEGER; !BEGIN "x:=0; "read(ch); "WHILE ch IN ['0'..'9'] DO #BEGIN $x:=10*x+(ord(ch)-ord('0')); " read(ch); #END; "writeln; "stoi:=x; !END; ! ue, to stop '); )read(keyboard,ch); )IF ch=chr(esc) THEN exit(displaydir) *ELSE BEGIN gotoxy(0,2);write(chr(cleos)); END; (END; &END; ! write(dosdir[0].dnumentries,' files on disk, ',cumsectors,' sectors in use'); $END; !END; $ !PROCEDURE catalog; !CONST "nextlink = 1; (* relative byte 1 of directory sector is link to 5next directory sector *) " "zerobase =11; (* first byte of file info in a directory sector *) "entrylength=35; (* DOS directory entries occupy 35 bytesk DO $BEGIN %tracknum:=dir_sector[nextlink]; %sectnum:=dir_sector[nextlink+1]; $END; "END; !WITH dosdir[0] DO "BEGIN #dnumentries:=entrycount; #dunitnum:=unitnum; "END; !displaydir;  END; (* catalog *)   (*$IDPTH2.1:TRANSFER.TEXT*)   BEGIx:=0; %WHILE NOT eodirsector(sectorindex,dir_sector,entrybase) DO %BEGIN &moveleft(dir_sector[entrybase],nextentry,entrylength); &entrycount:=entrycount+1; &filldirentry(dosdir[entrycount],nextentry); %END; $END; (*IF...THEN...ELSE *) #WITH dir_lin#sectnum:=firstdirsect; "END; !entrycount:=0; !WHILE NOT eodir(dir_link) DO "BEGIN #IF NOT readtrksec(unitnum,dir_link,dir_sector,ioerror) $THEN BEGIN writeln('ioerror ',ioerror,' reading directory'); /exit(catalog); )END $ELSE BEGIN %sectorinde)*entrylength; $nofile:=(dirsector[entrybase] IN [0,mark]); #END; "eodirsector:=nofile; !END; !  BEGIN (* catalog *) !page(output); !IF NOT getunitnum(unitnum) THEN exit(catalog); !WITH dir_link DO "BEGIN #tracknum:=dirtrack; ) & !FUNCTION eodirsector(VAR index:indexrange; 7VAR dirsector:sectbuffer;VAR entrybase:byterange):BOOLEAN; !VAR "nofile:BOOLEAN; !BEGIN "nofile:=TRUE; "WHILE (nofile AND (index' ',eb[nameoffset+didleng-1]); $(* non_blank=0 if and only if no trailing blanks *) ocked:=FALSE; $FOR j:=0 TO (didleng-1) DO %BEGIN &(* set the high bit low to get true ASCII *) &eb[nameoffset+j]:=eb[nameoffset+j] MOD 128; &(* eliminate any weird characters *) ndoffset]; $IF NOT ((kind MOD lockbit) IN [0,1,2,4]) THEN dfkind:=unknown %ELSE CASE (kind MOD lockbit) OF +0:dfkind:=dftext; +1:dfkind:=dfinteger; +2:dfkind:=applesoft; +4:dfkind:=binary; +END; $IF ((kind DIV lockbit)=1) THEN locked:=TRUE %ELSE le file *) "lockbit =128; (* locked files have the high bit of the file type byte set *) !VAR "j,kind:byterange; ! nonblank:0..didleng; !BEGIN "WITH de DO #BEGIN $filetsl.tracknum:=eb[linkoffset]; $filetsl.sectnum:=eb[linkoffset+1]; $kind:=eb[ki5track-sector list *) "kindoffset = 3; (* relative byte 2 designates the file type of the entry *) "nameoffset = 4; (* relative byte 3 is the beginning of the file name *) "countoffset=34; (* relative byte 33 is the sector count (MOD sectsize) for 5thnk:link):BOOLEAN; !BEGIN "WITH dirlink DO #eodir:=(sectnum=0) AND (tracknum=0); !END;  !PROCEDURE fill_dir_entry(VAR de:dosdirentry;VAR eb:entrybuffer); !CONST "linkoffset = 1; (* relative byte zero for an entry gives the location of its indexrange=0..maxindex; ! entrybuffer=PACKED ARRAY[1..entrylength] OF byterange; ! !VAR "sectorindex:indexrange; ! entrybase:byterange; "dir_link:link; "dir_sector:sectbuffer; "nextentry:entrybuffer; "entrycount:dirrange; " !FUNCTION eodir(dirli *) "mark =maxbyte; (* directory entries which have been deleted are 'marked' 5in (relative) byte zero *) ! maxindex = 7; (* maximum of 7 directory entries in a sector *) ! "space= 32; (* ASCII space *) "tilde=126; (* ASCII tilde *) !TYPE "N !WITH dosdir[0] DO "BEGIN dfkind:=volinfo; dnumentries:=0; dunitnum:=0; END; !page(output); !gotoxy(0,5); !writeln('Welcome to PUFFIN!'); !REPEAT "printmenu; "readcommand(ch); "CASE ch OF #'c','C':catalog; #'d','D':displaydir; #'t','T':transfer; #END; !UNTIL ch IN ['Q','q'];  END. ( (.PROC MONITOR ( (LOAD USER,03F8,03 ;CTL-Y JUMP (ROMSELECT (JMP MON  RET PLA ;REMOVE CTL-Y ADDR (PLA (STA 0C088 ;SWITCH ON RAM BANK1 (RTS  USER JMP RET   (.PROC PRINTCR (ROMSELECT (LDA #8D ; (JSR COUT (DDR (LDA VAL (LDY #00 (STA (ADDR),Y ;POKE VAL INTO ADDR (STA 0C088 ;WRITE-PROTECT RAM 6;SELECT SECOND BANK (PUSH RETURN (RTS ( ( (.PROC BANK2POKE,2 ( (.REF POKE ( (STA 0C081 ;WRITE-ENABLE ( ;SECOND 4K BANK (JMP POKE ((LDA %1+1 (PHA (LDA %1 (PHA (.ENDM ( (.MACRO ROMSELECT (STA 0C08A (.ENDM ( (.MACRO RAMSELECT (JSR BANK (.ENDM ( ( ( (.PROC BANK1POKE,2 ( (.DEF POKE ( (STA 0C089 ;WRITE-ENABLE 6;FIRST 4K BANK  POKE POP RETURN (POP VAL (POP A ( (.MACRO POP ;FORMAT: POP ADDR (PLA (STA %1 (PLA (STA %1+1 (.ENDM (  ;PUSH ADDR ONTO STACK ( (.MACRO PUSH ;FORMAT: PUSH ADDR ;PASSED PARAM.  VAL .EQU 00004 ;PASSED PARAM.   ;LOAD DATA OR ROUTINE (NO MORE THAN 256 BYTES) ( (.MACRO LOAD ;FORMAT: (LDY #00 ;LOAD SOURCE,DEST,LEN  $1 LDA %1,Y (STA %2,Y (INY (CPY #%3 (BNE $1 (.ENDM (  ;POP ADDR FROM STACK 0FE89   PRBYTE .EQU 0FDDA ;CHAR OUTPUT  COUT .EQU 0FDED ;SUBROUTINES  PRNTYX .EQU 0F940   PCADJ .EQU 0F953  PC .EQU 0003A ;PROG COUNTER  MON .EQU 0FF65 ;MONITOR   RETURN .EQU 00000 ;PASCAL RET ADDR  ADDR .EQU 00002  ;---------------------------------  ;LISTING #2: PMU.PROC  ;  ;WRITTEN BY RON DEGROAT 4/81  ;---------------------------------   ;MONITOR ROM ADDRS   SETNORM .EQU 0FE84 ;I/O INIT  INIT .EQU 0FB2F  SETVID .EQU 0FE93  SETKBD .EQUSTA 0C088 (RTS ( ( (.PROC PRINTXADDR,1 ( (POP RETURN (PLA ;GET ADDR (TAX (PLA (TAY (ROMSELECT (JSR PRNTYX ;PRINT HEX ADDR (LDA #0A0 ;PRINT ONE SPACE (JSR COUT (STA 0C088 (PUSH RETURN (RTS ( ( (.PROC PRINTHEXBYTE,1 ( (.REF BANK ;USED BY RAMSELECT ( (POP RETURN (POP ADDR (RAMSELECT (LDY#00 (LDA (ADDR),Y ;GET HEX BYTE (ROMSELECT (JSR PRBYTE ;PRINT HEX BYTE T ZERO )STA ORIGIN+1 ) )LDA SEARCHADDR ;PUBLIC ADDR )STA SRCHADDR ;ZERO PG ADDR )LDA SEARCHADDR+1 )STA SRCHADDR+1 )  LOOP LDY #00 ;INIT Y EVERY TIME )FIND FIRST ;CHECK FOR MATCH )FIND SECOND ;ONLY IF 1ST MATCHES )LDA NOTHIRD ;ETURN ;PASCAL RETURN ADDR ) )PLA ;DISCARD OFFSET )PLA )PLA )PLA ) )PULL NOTHIRD ;GET PARAMETERS )PULL THIRD ;AND STORE VALUES )PULL SECOND )PULL FIRST ) )LDA #00 ;PUSH MSB OF )PHA ;FUNCTION RESULT )STA ORIGIN ;START A).ENDM )  THIRD .EQU 12  SECOND .EQU 13 ;SEQUENCE TO SEARCH FOR  FIRST .EQU 15  NOTHIRD .EQU 14 ;IS THERE A THIRD NO.?  SRCHADDR .EQU 16 ;SEARCH ADDR  ORIGIN .EQU 18 ;STARTING ADDR OF SEARCH ) ).PUBLIC SEARCHADDR ) )POP R;PULL & STORE PARAMETER )PLA )STA %1 )PLA ).ENDM ) ).MACRO FIND )LDA @SRCHADDR,Y )CMP %1 )BNE NOMATCH )INY ;BUMP Y FOR NEXT BYTE ON FOUND(ADDR:INTEGER; FIRST,  ; SECOND,THIRD:BYTE;  ; NOTHIRD:BOOLEAN):BOOLEAN;  ;(BYTE:0..255)  ;  ;WRITTEN BY RON DEGROAT 15-JUN-80  ;---------------------------------------    ).FUNC FOUND,4 ) ).MACRO PULL PC),Y (ROMSELECT (RTS ( (  ;---------------------------------------  ;  ; THE FOLLOWING EXTERNAL PROCEDURES AND  ; FUNCTIONS ARE USED BY SEARCHMEMORY  ;  ;--------------------------------------- ;---------------------------------------  ;FUNCTI(NOP (NOP   CHANGE3 JSR DIS3 (NOP   DIS1 RAMSELECT ;SWITCH ON LANG CARD (LDA (PC,X) ;GET OPCODE BYTE (ROMSELECT ;SWITCH ON ROM (TAY (RTS   DIS2 RAMSELECT (LDA(PC),Y (ROMSELECT (JMP PRBYTE (  DIS3 CMP #0E8 (RAMSELECT (LDA ( INIT (JSR SETVID (JSR SETKBD (RAMSELECT ;SWITCH ON LANG CARD (RTS (  CHANGE1 JSR DIS1   CHANGE2 JSR INSDS1 (PHA (JSR DIS2 COPY  INSTDSP .EQU INSDS1+04E  PATCH1 .EQU INSDS1+00A  PATCH2 .EQU INSTDSP  PATCH3 .EQU INSDS1+0B0   ;MAKE NECESSARY PATCHES & SET UP VIDEO  (LOAD CHANGE1,PATCH1,03 (LOAD CHANGE2,PATCH2,09 (LOAD CHANGE3,PATCH3,04 (JSR SETNORM (JSRP ( (.REF BANK ( (JMP BEGIN ;SKIP COPY AREA (  ;COPY MAIN PART OF ROM DISASSEMBLER  ;HERE IN RAM SO THAT IT CAN BE  ;MODIFIED TO WORK WITH PASCAL   INSDS1 .BLOCK 0DF ;COPY GOES HERE   BEGIN ROMSELECT (LOAD 0F882,INSDS1,0DF ;MAKE (LDA IC+1 (STA PC+1 (ROMSELECT (JSR INSTDSP ;DISASM ONE INST (JSR PCADJ ;ADJUST PC (STA PC (STY PC+1 (STA IC ;ADJUST IC (STY IC+1 (STA 0C088 ;SWITCH BACK TO (RTS ;BANK1 BEFORE RET ( ( (.PROC INITDISASSEM ( (.DEF INSTDSS ( ( (.PROC DISASSEM ( (.PUBLIC IC ;INSTR COUNTER (.REF INSTDSP,BANK ( (LDA IC ;TRANSFER IC (STA PC ;TO PC AL ;CHARS AS '.' (LDA #0AE ; '.'  NORMAL ROMSELECT (JSR COUT (STA 0C088 (PUSH RETURN (RTS ( ( (.PROC SWITCHBANK ( (.DEF BANK ( (LDA BANK+1 ;CHANGE 0C088 (EOR #08 ;TO 0C080 AND (STA BANK+1 ;VICE VERSA (RTS  BANK STA 0C088 (RT(LDA #0A0 ;PRINT SPACE (JSR COUT (STA 0C088 (PUSH RETURN (RTS ( ( (.PROC PRINTCHARBYTE,1 ( (.REF BANK ( (POP RETURN (POP ADDR (RAMSELECT (LDY #00 (LDA (ADDR),Y;GET CHAR BYTE (ORA #80 ;SET HI BIT (CMP #0A0 ;PRINT CONTROL (BCS NORMIS THERE A 3RD? )CMP #01 )BEQ MATCH ;IF NOTHIRD THEN MATCH )FIND THIRD ;ELSE CHECK 3RD )  MATCH LDA #01 ;SET FOUND = TRUE )CLC ;AND GOTO END )BCC END )  NOMATCH INC SRCHADDR ;BUMP LSB OF SRCHADDR AND  BNE NOBUMP ;BRANCH IF NO CARRY ) )INC SRCHADDR+1 ;BUMP MSB OF SRCHADDR )  NOBUMP LDA SRCHADDR+1 ;IF MSB OF SRCHADDR = )CMP ORIGIN+1 ;MSB OF ORNDADDR,ADDR,VAL,BANK :INTEGER; $NUMOFCOLS,TEMP :INTEGER; $IC (*INST. COUNTER*) :INTEGER; $SEARCHADDR :INTEGER; $EOL,BELL,CH :CHAR; $ESC,BS,CR :CHAR; $DESET,HEXSET,PMUSET :SETOFCHAR; $CHRSET,OKSET *$S+*)  PROGRAM PMU;   CONST PRINTADDR=-16128; (* $C100 *) &COUT1=-528; (* $FDF0 *)   TYPE MAGIC=RECORD CASE BOOLEAN OF ,TRUE: (ADDR: INTEGER); ,FALSE:(VECTOR:^INTEGER); +END; % %SETOFCHAR=SET OF CHAR;  %BYTE=0..255;    VAR E (*************************************) (* LISTING #1: PASCAL MEMORY UTILITY *)  (* *)  (* WRITTEN BY RON DEGROAT 15-APR-81 *)  (* SEARCH MODE ADDED 15-JUL-81 *)  (*************************************)   (N^HAGES )BNE LOOP )LDA 0C088 ;WRITE-PROTECT RAM )RTS  ).END ( )LDA #00 )STA 00 )STA 02 )TAY )TAX )LDA 0C083 ;READ-ENABLE 2ND BANK  LOOP LDA (00),Y ;MOVE D000-DFFF )STA (02),Y ;TO 2000-2FFF )INY )BNE LOOP )INC 01 ;SOURCE PAGE # )INC 03 ;DESTINATION PAGE # )INX )CPX #10 ;TRANSFER SIXTEEN P ;RETURN TO PASCAL HOST ) ) ).PROC MOVEBANK2 ) )LDA #0D0 ;(0000) = D000 )STA 01 )LDA #20 ;(0002) = 2000 )STA 03 DR+1 )LDA #00 )STA SRCHADDR ) )CLC )BCC LOOP ;DO IT AGAIN )  ABORT LDA #00 ;MAKE RESULT FALSE  END PHA ;PUSH LSB OF RESULT )LDA SRCHADDR )STA SEARCHADDR )LDA SRCHADDR+1 )STA SEARCHADDR+1 )PUSH RETURN )RTS IGIN )BNE NOTDONE )LDA SRCHADDR ;THEN CHECK LSB )CMP ORIGIN )BEQ ABORT ;IF = THEN ABORT )  NOTDONE LDA SRCHADDR+1 ;SKIP SOFT SWITCHES )CMP #0C0 ;FROM $C030 TO $C100 )BNE LOOP )LDA SRCHADDR )CMP #30 )BCC LOOP )LDA #0C1 )STA SRCHAD :SETOFCHAR; $GOOD,ESCOK :BOOLEAN; $CSW :MAGIC; $HEXADDR,HEXBYTE :STRING; $PSW :STRING[3];   PROCEDURE INITDISASSEM; EXTERNAL;  PROCEDURE DISASSEM; (* USES IC *) EXTERNAL;  PROCEDURE MONITOR; EXTERNAL;  PROCEDURE PRINTCR; EXTERNAL;  PROCEDURE SWITCHBANK; EXTERNAL;  PROCEDURE PRINTXADDR(ADDR:INTEGER); EXTERNAL; DDR('ENDADDR ==> '); !PAGE(OUTPUT); !PRINTCR; !ENDADDR:=ADDR; !ADDR:=TEMP; !WHILE ADDR<=ENDADDR DO LINEOFBYTE(ADDR);  END;    PROCEDURE BANKCHANGE;   BEGIN "BANK:=(BANK MOD 2)+1; "SWITCHBANK;  END;    PROCEDURE EXAMINE;   VAR CH:CHOR I:=1 TO 20 DO LINEOFBYTE(ADDR);  END;    PROCEDURE XLIST;   BEGIN !PROMPTAT(0,'EXAMINE: LIST'); !GETADDR('STARTADDR ==> '); !PAGE(OUTPUT); !XNEXT;  END;    PROCEDURE XRANGE;   BEGIN !GETADDR('STARTADDR ==> '); !TEMP:=ADDR; !GETA!PRINTXADDR(ADDR); !FOR J:=ADDR TO ADDR+NUMOFCOLS-1 DO #PRINTHEXBYTE(J); !FOR J:=ADDR TO ADDR+NUMOFCOLS-1 DO #PRINTCHARBYTE(J); !ADDR:=ADDR+NUMOFCOLS; (*ADJUST ADDR*) !PRINTCR;  END;    PROCEDURE XNEXT;  VAR I :INTEGER;  BEGIN !PRINTCR; !FEXBYTE); &IF BANK=1 THEN BANK1POKE(ADDR,VAL) 0ELSE BANK2POKE(ADDR,VAL); $END; "PRINTHEXBYTE(ADDR); "PRINTCR; "ADDR:=ADDR+1; !UNTIL FALSE;  END; (*CHANGE*)    PROCEDURE LINEOFBYTE(VAR ADDR:INTEGER);  VAR J :INTEGER;  BEGIN RITE('TO QUIT, TO SKIP)'); "GOTOXY(79,0); "IC:=ADDR; "PRINTXADDR(ADDR); "PRINTHEXBYTE(ADDR); "GOTOXY(9,23); "GETSTRING(HEXBYTE,HEXSET+[CR],2); "GOTOXY(79,0); "DELETE(HEXBYTE,LENGTH(HEXBYTE),1); "IF LENGTH(HEXBYTE)<>0 THEN $BEGIN &VAL:=DEC(H=DEC(HEXADDR);  END;    PROCEDURE CHANGE;   BEGIN !PROMPTAT(0,'CHANGE: ( '); !WRITE('TO QUIT, TO SKIP)'); !GETADDR('STARTADDR ==> '); !PAGE(OUTPUT); !PRINTCR; (*START PRINTING AT LEFT*) !REPEAT "PROMPTAT(1,'CHANGE: ( '); "W!FOR STRPTR:=1 TO LENGTH(HEXSTR) DO "BEGIN #DIGIT:=SCAN(16,=HEXSTR[STRPTR],XDIGITS); #NUM:=NUM*16+DIGIT; "END; !DEC:=NUM;  END;    PROCEDURE GETADDR(STR:STRING);   BEGIN "WRITELN;WRITELN; "WRITE(STR); "GETSTRING(HEXADDR,HEXSET,4); "ADDR:INTEGER;S:STRING);  BEGIN !GOTOXY(0,L); !WRITE(S,EOL);  END;   FUNCTION DEC(HEXSTR:STRING):INTEGER;   VAR DIGIT,NUM, $STRPTR :INTEGER;  XDIGITS :PACKED ARRAY[0..15] OF CHAR;   BEGIN !NUM:=0; !XDIGITS:='0123456789ABCDEF'; KSET+[CR,BS]; " "S1[1]:=GETCHAR(GETSET); " "IF S1[1] IN OKSET THEN #STEMP:=CONCAT(STEMP,S1) #ELSE IF S1[1]=BS THEN $BEGIN %WRITE(BS,' ',BS); %DELETE(STEMP,LEN,1); $END; !UNTIL S1[1]=CR; !S:=STEMP;  END; (*GETSTRING*)   PROCEDURE PROMPTAT(L:EAN; $LASTCHAR :BOOLEAN; $GETSET :SETOFCHAR; $  BEGIN !S1:=' '; STEMP:=''; !REPEAT "LEN:=LENGTH(STEMP); "FIRSTCHAR:=(LEN=0); "LASTCHAR:=(LEN=MAXLEN); " "IF FIRSTCHAR THEN GETSET:=OKSET "ELSE IF LASTCHAR THEN GETSET:=[CR,BS] 'ELSE GETSET:=O#ELSE IF CH IN [' '..CHR(125)] *THEN WRITE(CH); !UNTIL GOOD; !GETCHAR:=CH;  END;    PROCEDURE GETSTRING(VAR S:STRING; $OKSET:SETOFCHAR; MAXLEN:INTEGER); $  VAR S1 :STRING[1]; $STEMP :STRING; $LEN :INTEGER; $FIRSTCHAR :BOOL   FUNCTION GETCHAR(OKSET:SETOFCHAR):CHAR;   VAR CH :CHAR; $GOOD :BOOLEAN;   BEGIN !REPEAT "READ(KEYBOARD,CH); "IF EOLN(KEYBOARD) THEN CH:=CR; "IF (CH=ESC) AND ESCOK THEN ABORT; "GOOD:=CH IN OKSET; "IF NOT GOOD THEN WRITE(BELL) ING: The variable IC is public *)  (* to DISASSEM which automatically *)  (* adjusts IC to point to the next *)  (* instruction to be disassembled. *)    PROCEDURE ABORT;   BEGIN !PAGE(OUTPUT); !ESCOK:=FALSE; !EXIT(DOCHOICE);  END; PROCEDURE PRINTHEXBYTE(ADDR:INTEGER); EXTERNAL;  PROCEDURE PRINTCHARBYTE(ADDR:INTEGER); EXTERNAL;  PROCEDURE BANK1POKE(ADDR,VAL:INTEGER); EXTERNAL;  PROCEDURE BANK2POKE(ADDR,VAL:INTEGER); EXTERNAL;   PROCEDURE DOCHOICE; FORWARD;   (* WARNAR;   BEGIN !REPEAT "PROMPTAT(0,'EXAMINE: L(IST N(EXT '); "WRITE('R(ANGE B(ANK[',BANK,'] Q(UIT'); "CH:=GETCHAR(DESET); "PAGE(OUTPUT); "CASE CH OF #'L','l':XLIST; #'N','n':XNEXT; #'R','r':XRANGE; #'B','b':BANKCHANGE; "END;  UNTIL CH='Q';  END; (*EXAMINE*)    PROCEDURE NEXT;  VAR I :INTEGER;  BEGIN  FOR I:=1 TO 20 DO DISASSEM(* IC *); "PRINTCR;  END;    PROCEDURE LIST;   BEGIN !PROMPTAT(0,'DISASM: LIST'); !GETADDR('STARTADDR ==> '); !PAGE(OUTPUT); !IC:=ADDR; (*ICDR+1; (COLCOUNT:=(COLCOUNT+1) MOD NUMOFCOLS; (IF (COLCOUNT=0) THEN *IF (PSW='ON') THEN PRINTCR; 'END &ELSE (DONE:=TRUE; %UNTIL DONE; % %IF SEQNOTFOUND THEN PROMPTAT(22,'NOT FOUND') 4ELSE PRINTCR; %WRITE(BELL); #END; !UNTIL CH IN ['Q','q'];  HIRD THEN &WRITELN(STHIRD:4); % %GOTOXY(80,0); (*MOVE CURSOR OFF SCREEN*) %PRINTCR; (*START PRINTING AT LEFT*) % %REPEAT &IF (FOUND(FIRST,SECOND,THIRD,NOTHIRD)) THEN 'BEGIN (SEQNOTFOUND:=FALSE; (PRINTXADDR(SEARCHADDR); (SEARCHADDR:=SEARCHAD  (*ACTUAL SEARCHING PERFORMED IN EXTERNAL PROCEDURE FOUND*) % %MOVEBANK2; %SEQNOTFOUND:=TRUE; %SEARCHADDR:=0; (*START SEARCH AT ZERO*) %COLCOUNT :=0; %DONE:=FALSE; ( %GOTOXY(0,20); %WRITE('SEQUENCE',SFIRST:4,SSECOND:4); %IF NOT NOTD); &END & %ELSE &BEGIN 'FIRST :=ORD(SFIRST[1]); 'SECOND:=ORD(SSECOND[1]); 'THIRD :=ORD(STHIRD[1]); &END; " %PROMPTAT(12,'NOW SEARCHING MEMORY...');WRITELN; %WRITELN('SECOND BANK (D000-DFFF) COPIED INTO'); %WRITE('HIRES SCREEN (2000-2FFF)'); ,SLEN);WRITELN; %IF NOTHIRD=FALSE THEN &BEGIN 'WRITE('THIRD ==> '); 'GETSTRING(STHIRD,OKSET,SLEN);WRITELN; &END; !  (*CONVERT TO INTEGER*) ! %IF CH IN ['H','h'] THEN &BEGIN 'FIRST :=DEC(SFIRST); 'SECOND:=DEC(SSECOND); 'THIRD :=DEC(STHIR:=2; END; &'C','c':BEGIN OKSET:=CHRSET; SLEN:=1; END; %END; (*CASE*) #  (*GET THE SEQUENCE*) # %WRITELN; %WRITELN('LOOK FOR SEQUENCE'); %WRITE('FIRST ==> '); %GETSTRING(SFIRST,OKSET,SLEN);WRITELN; %WRITE('SECOND ==> '); %GETSTRING(SSECOND,OKSET!IF CH IN ['2','3'] THEN "CASE CH OF #'2':BEGIN (NOTHIRD:=TRUE; (FOR2OR3:=2; 'END; #'3':BEGIN (NOTHIRD:=FALSE; (FOR2OR3:=3; 'END; "END (*CASE*) " "ELSE #IF NOT (CH IN ['Q','q']) THEN $BEGIN % %CASE CH OF &'H','h':BEGIN OKSET:=HEXSET; SLENDDR :STRING[4];  (  BEGIN !NOTHIRD:=FALSE; !THIRD:=0; !STHIRD:='0'; !FOR2OR3:=3; ! !REPEAT !GOTOXY(0,0); !WRITE('>SEARCH[',FOR2OR3,']: H(EX, C(HAR, Q(UIT'); !CH:=GETCHAR(['H','h','C','c','Q','q','2','3']); !PAGE(OUTPUT); ! ***********) "  PROCEDURE SEARCHMEM;   VAR FIRST,SECOND,THIRD :BYTE;  SFIRST,SSECOND,STHIRD :STRING; $SLEN,  FOR2OR3,COLCOUNT :INTEGER; $NOTHIRD, $SEQNOTFOUND, $DONE :BOOLEAN; $CH :CHAR; $XAIRD:BOOLEAN):BOOLEAN;  EXTERNAL;  PROCEDURE MOVEBANK2;  EXTERNAL; $  (********************************************)  (* SEARCH MEMORY FOR SEQUENCE OF 2 OR 3 *)  (* HEXADECIMAL OR CHARACTER VALUES *)  (*********************************#END;  (*$I+*)   IF PSW='OFF' THEN #BEGIN $CSW.VECTOR^:=PRINTADDR; $PSW:='ON'; $NUMOFCOLS:=16; #END "ELSE " BEGIN $CSW.VECTOR^:=COUT1; $PSW:='OFF'; $NUMOFCOLS:=8; #END;  END; (*PRINT*)   FUNCTION FOUND(FIRST,SECOND,THIRD:BYTE; /NOTH; #'R','r':RANGE; #'B','b':BANKCHANGE; "END; (*CASE*) !UNTIL CH IN ['Q','q'];  END;    PROCEDURE PRINT;   BEGIN   (*$I-*) "UNITCLEAR(6); "IF IORESULT<>0 THEN #BEGIN $PROMPTAT(3,'SORRY, NO PRINTER'); $WRITE(' ON-LINE'); $EXIT(PRINT); SSEM(* IC *); "PRINTCR;  END;    PROCEDURE DISASM;   VAR CH:CHAR;   BEGIN !REPEAT "PROMPTAT(0,'DISASM: L(IST N(EXT '); "WRITE('R(ANGE B(ANK[',BANK,'] Q(UIT'); "CH:=GETCHAR(DESET); "PAGE(OUTPUT); "CASE CH OF #'L','l':LIST; #'N','n':NEXT (INSTR COUNTER)*) !NEXT; (*PUBLIC TO DISASSEM*)  END;    PROCEDURE RANGE;   BEGIN "PAGE(OUTPUT); "PROMPTAT(0,'DISASM: RANGE'); "GETADDR('STARTADDR ==> '); "IC:=ADDR; "GETADDR('ENDADDR ==> '); "PAGE(OUTPUT); "WHILE IC<=ADDR DO DISAEND; (*SEARCH*)    PROCEDURE DOCHOICE;   BEGIN !PAGE(OUTPUT); ESCOK:=TRUE; !CASE CH OF "'D','d':DISASM; "'E','e':EXAMINE; "'C','c':CHANGE; "'S','s':SEARCHMEM; "'B','b':BANKCHANGE; "'P','p':PRINT; "'M','m':MONITOR; !END; !ESCOK:=FALSE;  END;    PROCEDURE INITIALIZE;   BEGIN !BELL:=CHR(7); (*CTL-G*) !EOL:=CHR(29); (*CTL-]*) !ESC:=CHR(27); (*CTL-[*) !BS:=CHR(8); (*CTL-H*) !CR:=CHR(13); (*CTL-M*) ! !ESCOK:=FALSE; !BANK:=1; !PSW:='ET) AND NOT INDENTBYTE (THEN WRITE(OUTFILE,TEMP) (ELSE BEGIN *IF FILTRATION ,THEN INDENTBYTE:=(TEMP=CHR(16)) ,ELSE WRITE(OUTFILE,'[',ORD(TEMP),']') (END $END; (*I LOOP*) " "IF OUTDEVICE <> DISC &THEN WRITELN(OUTFILE,CHR(13),'END OF BLOCKNUMBER ',; $TEMP :CHAR; $NOSKIP :BOOLEAN; $  BEGIN "IF OUTDEVICE <> DISC $THEN BEGIN )WRITELN(OUTFILE,CHR(13)); )WRITELN(OUTFILE,'BLOCKNUMBER ',BLKNUM); )WRITELN(OUTFILE); 'END; " "FOR I:=0 TO 511 DO $BEGIN &TEMP:=BLOCKARRAY[I]; &IF (TEMP IN PRINTS BEGIN "REPEAT $WRITELN; $WRITE(S); $READ(CH); $WRITELN; $UNITCLEAR(1); $GOOD:=CH IN OKSET; $IF NOT GOOD THEN &WRITE(CHR(7)); "UNTIL GOOD; "PROMPT:=CH;  END;   PROCEDURE WRITEBLOCK(BLKNUM:INTEGER; BLOCKARRAY:BLOCK);   VAR I :INTEGER$AGAIN : CHAR; $FILTRATION: BOOLEAN; $INDENTBYTE: BOOLEAN; $OUTDEVICE : OUTMODE; $INDEVICE : INMODE; $OUTFILE : TEXT; $PRINTSET : SET OF CHAR; $  FUNCTION PROMPT(S:STRING; OKSET:CHARSET):CHAR;   VAR GOOD: BOOLEAN; &CH: CHAR; & ITTEN AS THEIR *)  (* ASCII VALUE IN BRACKETS. *)    TYPE OUTMODE = (PRNTR, CONSL, DISC); %INMODE = 4..5; %BLOCK = PACKED ARRAY [0..511] OF CHAR; %CHARSET = SET OF CHAR; %  VAR START,STOP: INTEGER; EXT FILES. THE FILES SO RECOVERED MAY BE WRITTEN TO *)  (* THE CONSOLE, PRINTER, OR A DISC FILE. THE FILES ARE ACCESSED BY *)  (* INITIAL BLOCK NUMBER AND NUMBER OF BLOCKS TO BE READ. NONPRINT- *)  (* ABLE CHARACTERS CAN EITHER BE SUPPRESSED OR WRPROGRAM RECOVER;   (* BY W. JANES, DECEMBER 28, 1980 *)   (* THIS PROGRAM USES THE LOW LEVEL PROCEDURE UNITREAD TO READ FILES *)  (* WHOSE DIRECTORY HAS BEEN DESTROYED, AND IS DESIGNED MAINLY TO *)  (* RECOVER TN^SSH B(ANK[',BANK,'] Q(UIT'); "CH:=GETCHAR(PMUSET); "DOCHOICE; !UNTIL CH IN ['Q','q'];   END. (127)]; ! !HEXSET:=['0'..'9']+['A'..'F']; ! !INITDISASSEM; !  END; (*INIT*)   BEGIN (*MAIN PROGRAM*)  !INITIALIZE; (*EVERYTHING*) ! !REPEAT "PROMPTAT(0,'PMU: D(ISASM E(XAMINE '); "WRITE('C(HANGE P(RINT[',PSW,'] M(ONITOR '); "WRITE('S(EARCOFF'; (*PRINTER SWITCH*) !NUMOFCOLS:=8; !ADDR:=0; !CSW.ADDR:=54; (*CHAR OUTPUT SWITCH*) ! !DESET:=['L','l','N','n','R','r', )'B','b','Q','q']; ! !PMUSET:=['D','d','E','e','B','b','M','m', *'S','s','C','c','P','p','Q','q']; ! !CHRSET:=[' '..CHRBLKNUM);  END; (*WRITEBLOCK*)   PROCEDURE GETPRNTOPTION(VAR RSLT:BOOLEAN);   VAR CH: CHAR;   BEGIN "WRITELN; "WRITELN('THE OUTPUT PRINT OPTIONS ARE'); "WRITELN(' A)LL CHARACTERS PRINTED, USING ORD WHEN NEEDED'); "WRITELN(' F)ILTER OUT NONPRINTABLE CHARACTERS'); "CH:=PROMPT('SELECTION ? ',['A','F']); "RSLT:=(CH='F');  END; (*GETPRINTOPTION*)   PROCEDURE INITIALIZE(VAR PRNTSET:CHARSET; VAR INDEV:INMODE; 5VAR OUTDEV:OUTMODE; VAR FILTER:BOOLEAN); "..15 ] OF CHAR; "HEX_BYTE : PACKED ARRAY[0..1 ] OF CHAR; "HEX_STR : STRING[5]; "BLK_NUM, BYTE, "DEV_NUM, DEC, "NUM_COLS : INTEGER; "CHOICE,CH : CHAR; "PRINTER_OFF : BOOLEAN; "F : INTERACTIVE;   PROCEDURE DEC_TO_HEX_Blly appeared in Jan 81 Call-A.P.P.L.E. *)  (* *) (*************************************************)   CONST SP=' '; "  VAR "BUF : PACKED ARRAY[0..511] OF 0..255; "HEX_DIGIT : PACKED ARRAY[0  PROGRAM PASCAL_ZAP;   (*************************************************)  (* *)  (* Written by Philip B. Ender *)  (* Modified by Ron DeGroat Jun 81 *)  (* OriginaA B  O^BǢEPEAT &GETRANGE(START,STOP); &PROCESSBLOCKS(START,STOP); &AGAIN:=PROMPT('PROCESS ANOTHER RANGE OF BLOCKS? ',['Y','N']); $UNTIL AGAIN = 'N'; !END. ITE('START AT BLOCK? '); #READLN(FIRST); #MAX:=280-FIRST; #WRITELN; #WRITE('NUMBER OF BLOCKS? (1..',MAX,') '); #READLN(NUM); #LAST:=FIRST+NUM-1; !END; (*GETRANGE*) ! !BEGIN (*MAIN PROGRAM*) $INITIALIZE(PRINTSET,INDEVICE,OUTDEVICE,FILTRATION); $RTREAD(INDEVICE,BUFFER,512,BLOCKNUM); 'WRITEBLOCK(BLOCKNUM,BUFFER); %END; (*LOOP*) #IF OUTDEVICE=DISC THEN CLOSE(OUTFILE,LOCK); !END; (*PROCESSBLOCKS*) ! !PROCEDURE GETRANGE(VAR FIRST,LAST:INTEGER); ! !VAR MAX,NUM:INTEGER; ! !BEGIN #WRITELN; #WR BEGIN "IF OUTDEVICE = DISC $THEN BEGIN +WRITELN; +WRITE('SAVE AS? '); +READLN(F); +F:=CONCAT(F,'.TEXT'); +REWRITE(OUTFILE,F); )END; ) #INDENTBYTE:=FALSE; (*USED TO DELETE [INDENT] AFTER [DLE]*) " #FOR BLOCKNUM:=FIRST TO LAST DO %BEGIN 'UNI %'D':BEGIN ,PRNTSET:=[CHR(32)..CHR(127),CHR(13),CHR(16)]; ,OUTDEV:=DISC; ,FILTER:=TRUE )END %END (*CASE*)  END; (*INITIALIZE*)   PROCEDURE PROCESSBLOCKS(FIRST,LAST:INTEGER); "  VAR BLOCKNUM:INTEGER; $BUFFER :BLOCK; $F :STRING; $ EGIN ,PRNTSET:=[CHR(32)..CHR(127),CHR(13)]; ,REWRITE(OUTFILE,'PRINTER:'); ,OUTDEV:=PRNTR; ,GETPRNTOPTION(FILTER); )END; %'C':BEGIN ,PRNTSET:=[CHR(32)..CHR(127),CHR(13)]; ,REWRITE(OUTFILE,'CONSOLE:'); ,OUTDEV:=CONSL; ,GETPRNTOPTION(FILTER); )END;  VAR SELECTION, DEVICE: CHAR;   BEGIN "DEVICE:=PROMPT('DISC UNIT TO BE READ (4..5)? ',['4','5']); "IF DEVICE='4' %THEN INDEV:=4 %ELSE INDEV:=5; "SELECTION:=PROMPT('OUTPUT TO P)RINTER C)ONSOLE D)ISC ', 5['P','C','D']); "CASE SELECTION OF %'P':BYTE(DEC: INTEGER);  BEGIN "HEX_BYTE[0]:=HEX_DIGIT[(DEC DIV 16)]; "HEX_BYTE[1]:=HEX_DIGIT[(DEC MOD 16)]  END;   PROCEDURE WRITE_BLOCK;  BEGIN "WRITELN; WRITELN; "WRITE('RESPOND YES TO WRITE TO BLOCK ', *BLK_NUM:3,SP:2); "READLN(CH); "IF CH='Y' THEN $UNITWRITE(DEV_NUM,BUF,512,BLK_NUM,0)  END;   PROCEDURE READ_BLOCK;  BEGIN "WRITELN; WRITELN;  WRITE('READ WHICH BLOCK?'); READLN(BLK_NUM); "WRITELN; "WRITE('READING BLOCK ',BLK_NUM:3); "UNITREAD(DEV_NUM,BUF,512,BLK_NUM,0)  EVE $END; "UNTIL CHOICE='Q'; "GOTOXY(8,8); WRITE('THAT''S ALL...');  END.   BEGIN (*MAIN PROGRAM*) "INITIALIZE; "REPEAT $SHOWMENU; $READ(KEYBOARD,CHOICE); $PAGE(OUTPUT); $CASE CHOICE OF &'R': READ_BLOCK; &'W': WRITE_BLOCK; &'D': DISPLAY_BUFFER; &'P': PRINT_BUFFER; &'A': ASCII_CHANGE; &'H': HEX_CHANGE; &'S': SET_DRIT DRIVE[',DEV_NUM,']');  WRITELN(SP:5,'Q(UIT'); "WRITELN; WRITELN; "WRITE('ENTER CHOICE: ')  END;   PROCEDURE INITIALIZE;  BEGIN "HEX_DIGIT:='0123456789ABCDEF'; PRINTER_OFF:=TRUE; "RESET(F,'CONSOLE:'); "NUM_COLS:=7; "DEV_NUM:=4;  END;  ITELN(SP:5,'MENU OF OPTIONS'); "WRITELN; "WRITELN(SP:5,'R(EAD BLOCK'); "WRITELN(SP:5,'W(RITE BLOCK'); "WRITELN(SP:5,'D(ISPLAY BUFFER'); "WRITELN(SP:5,'P(RINT BUFFER'); "WRITELN(SP:5,'A(SCII CHANGE'); "WRITELN(SP:5,'H(EX CHANGE'); "WRITELN(SP:5,'S(EDEC; *BUF[BYTE]:=DEC; BYTE:=BYTE+1 (END  UNTIL LEN=0  END;   PROCEDURE SET_DRIVE;  BEGIN "GOTOXY(0,8); "WRITE('SPECIFY DRIVE (4..5, 9..12): '); "READLN(DEV_NUM);  END;   PROCEDURE SHOWMENU;  BEGIN "PAGE(OUTPUT); "WRITELN; WRITELN; "WR$WRITELN(BYTE:3,': ',HEX_BYTE); $WRITE (BYTE:3,': '); $READLN(HEX_STR); $WRITELN; $LEN:=LENGTH(HEX_STR); $IF LEN<>0 THEN &IF LEN>2 THEN (WRITELN('HEX VALUE TOO LONG') &ELSE (BEGIN *IF LEN=1 THEN *HEX_STR:=CONCAT('0',HEX_STR); *HEX_STR_TO_   BEGIN "HI:=SCAN(16,=HEX_STR[1],HEX_DIGIT); "LO:=SCAN(16,=HEX_STR[2],HEX_DIGIT); "DEC:=HI*16+LO  END;   PROCEDURE HEX_CHANGE;   VAR LEN: INTEGER;   BEGIN "GET_BYTE; "REPEAT $DEC_TO_HEX_BYTE(BUF[BYTE]); CHR(BUF[BYTE]) $ELSE CH:='.'; "WRITELN(BYTE:3,': ',CH,' = CHR(',BUF[BYTE],')'); "WRITE (BYTE:3,': '); READ(CH); "WRITELN; "IF NOT EOLN THEN BUF[BYTE]:=ORD(CH); "BYTE:=BYTE+1 !UNTIL EOLN  END;   PROCEDURE HEX_STR_TO_DEC;   VAR LO,HI: INTEGER;ONSOLE:'); "NUM_COLS:=7;  END; (*PRINT_BUFFER*)   PROCEDURE GET_BYTE;  BEGIN "WRITE('BYTE TO BE CHANGED?'); "READLN(BYTE); WRITELN  END;   PROCEDURE ASCII_CHANGE;  BEGIN !GET_BYTE; !REPEAT "IF (BUF[BYTE]>31) AND (BUF[BYTE]<127) $THEN CH:="READ(KEYBOARD,CH);  END; "  PROCEDURE PRINT_BUFFER;  BEGIN "CLOSE(F); (* CLOSE F BEFORE RESETTING *) "RESET(F,'PRINTER:'); "NUM_COLS:=15; "PRINTER_OFF:=FALSE; "WRITE('PRINTING...'); "DISPLAY_BUFFER; "PRINTER_OFF:=TRUE; "CLOSE(F); "RESET(F,'CBLK_NUM:3, 2': SP-CONT; E-EXIT'); *READ(KEYBOARD,CH); PAGE(F); *IF CH='E' THEN EXIT(DISPLAY_BUFFER) (END "UNTIL BYTE>504; "WRITELN(F,'BLOCK ',BLK_NUM:3); "IF NOT PRINTER_OFF THEN GOTOXY(7,7); "WRITE('HIT ANY KEY TO CONTINUE'); NUM_COLS DO &IF (BUF[BYTE+COL]>31) AND )(BUF[BYTE+COL]<127) )THEN -WRITE(F,CHR(BUF[BYTE+COL])) )ELSE +WRITE(F,'.');  WRITELN(F); $BYTE:=BYTE+NUM_COLS+1; ROW:=ROW+1;  IF (ROW MOD 22 = 0) AND PRINTER_OFF THEN (BEGIN *WRITE(F,'BLOCK ',ND;   PROCEDURE DISPLAY_BUFFER;   VAR ROW,COL: INTEGER; $  BEGIN  ROW:=0; BYTE:=0; "REPEAT $WRITE(F,BYTE:3,':'); $FOR COL:=0 TO NUM_COLS DO &BEGIN (DEC_TO_HEX_BYTE(BUF[BYTE+COL]); (WRITE(F,HEX_BYTE:3) &END; $WRITE(F,SP); $FOR COL:=0 TON^ess} " "PAGE(OUTPUT); "PROMPTAT(0,'TRY TO INPUT ILLEGAL DATA.'); " "ALPHABET:=['A'..'Z']; "PROMPTAT(4,'INPUT ALFA STRING (LENGTH<=3): ');  GETSTRING(ALFASTRING,ALPHABET,3); " "WRITELN; "INT_NUM:=GETINTEGER('INTEGER (-10 THEN $BEGIN &DELETE(FP_STR,POWER,1); MAXLEN); "GET_HEX_VAL:=HEX_TO_INT(HEX_STR);  END;   (*********************************************)  (* CONVERT FLOATING PT. STRING TO REAL VALUE *) (*********************************************)   FUNCTION FP_NUM{(FP_STR:STRING):REAL}; $  VAR******************)   FUNCTION GET_HEX_VAL{(PROMPT:STRING; MAXLEN:INTEGER):INTEGER};   VAR HEXSET :SETOFCHAR; $HEX_STR :STRING;   BEGIN "WRITE(PROMPT,EOL); "HEXSET:=['0'..'9','A'..'F']; "IF MAXLEN>4 THEN MAXLEN:=4; "GETSTRING(HEX_STR,HEXSET,!FOR I:=1 TO LENGTH(HEXSTR) DO !BEGIN #DIGIT:=SCAN(16,=HEXSTR[I],HEXDIGIT); #NUM:=NUM*16+DIGIT; "END; !HEX_TO_INT:=NUM;  END;  (*******************************************)  (* GET HEX NUMBER AND RETURN INTEGER VALUE *) (*************************  END;   (*********************************)  (* CONVERT HEX STRING TO INTEGER *) (*********************************)   FUNCTION HEX_TO_INT{(HEXSTR:STRING):INTEGER};   VAR I,NUM,DIGIT :INTEGER;   BEGIN !NUM:=0; LOBYTE:= INT MOD 256; ! !HEXSTR[1]:= HEXDIGIT[HIBYTE DIV 16]; !HEXSTR[2]:= HEXDIGIT[HIBYTE MOD 16]; !HEXSTR[3]:= HEXDIGIT[LOBYTE DIV 16]; !HEXSTR[4]:= HEXDIGIT[LOBYTE MOD 16]; ! !WHILE (HEXSTR[1]='0') AND (LENGTH(HEXSTR)>1) DO DELETE(HEXSTR,1,1); !**********)   PROCEDURE INT_TO_HEX{(INT:INTEGER; VAR HEX_STR:STRING)};   VAR HIBYTE,LOBYTE :INTEGER; $  BEGIN !HEX_STR:='0000'; ! !IF INT<0 THEN #BEGIN %INT:= INT+32767+1;; %HIBYTE:= (INT DIV 256) +128; #END !ELSE #HIBYTE:= INT DIV 256; # (***********************************)   PROCEDURE PROMPTAT{LINE:INTEGER; MESSAGE:STRING};  BEGIN !GOTOXY(0,LINE); !WRITE(MESSAGE,EOL);  END;   (*********************************)  (* CONVERT INTEGER TO HEX STRING *)  (***********************=CONCAT(STEMP,S1) "ELSE IF S1[1]=BS THEN $BEGIN %WRITE(BS,' ',BS); %DELETE(STEMP,LEN,1); $END; "UNTIL S1[1]=CR; WRITELN; !S:=STEMP;  END;    (***********************************)  (* PLACE MESSAGE AT SPECIFIED LINE *) :=255; !REPEAT "LEN:=LENGTH(STEMP); "FIRSTCHAR:=(LEN=0); "LASTCHAR:=(LEN=MAXLEN); " "IF FIRSTCHAR THEN GETSET:=OKSET "ELSE IF LASTCHAR THEN GETSET:=[CR,BS] 'ELSE GETSET:=OKSET+[CR,BS]; " "S1[1]:=GETCHAR(GETSET); " "IF S1[1] IN OKSET THEN STEMP:R; MAXLEN:INTEGER}; $  VAR S1 :STRING[1]; $STEMP :STRING; $LEN :INTEGER; $FIRSTCHAR :BOOLEAN; $LASTCHAR :BOOLEAN; $GETSET :SETOFCHAR; $  BEGIN !S1:=' '; STEMP:=''; !IF MAXLEN<1 THEN MAXLEN:=1 !ELSE IF MAXLEN>255 THEN MAXLENTH(NUM_STR_TEMP); $FIRSTCHAR:=(LEN=0); $LASTCHAR:=(LEN=MAXLEN); " $IF PT_OK THEN OKSET:=OKSET+['.'] $ELSE OKSET:=OKSET-['.']; $ $IF FIRSTCHAR THEN GETSET:=OKSET $ELSE &IF LASTCHAR THEN GETSET:=[CR,BS] &ELSE GETSET:=OKSET+[CR,BS]-['-']; $ $S1[1]:=GET_CHAR(GETSET); $IF S1='.' THEN PT_OK:=FALSE; $ $IF S1[1] IN OKSET THEN &BEGIN (NUM_STR_TEMP:=CONCAT(NUM_STR_TEMP,S1); (IF S1[1] IN NUMSET THEN *BEGIN ,NUM:=FP_NUM(NUM_STR_TEMP); ,IF (NUM>MAXVAL) OR (NUM 127) OR (RPTR <> WPTR); $  END;   BEGIN {MAIN PROGRAM} ! "CR:=CHR(13); {ctl-M} "BS:=CHR(8); {ctl-H} "EOL:=CHR(29); {ctl-]} "EOS:=CHR(11); {ctl-K} "BELL:=CHR(7); "HEXDIGIT:='0123456789ABCDEF'; !  END. WPTR,KEYBD:BYTE;   BEGIN $MEMREF.ADDR:=-16384; (*KEYBD INPUT PORT*) $KEYBD:=MEMREF.BYTE^[0]; $ $MEMREF.ADDR:=-16616; (*BUFFER COUNTERS*) $RPTR:=MEMREF.BYTE^[0]; (*INPUT *) $WPTR:=MEMREF.BYTE^[1]; (*OUTPUT*) $ WITH EXTERNAL CONSOLE *) (***************************************)   FUNCTION KEYPRESS{:BOOLEAN};   TYPE BYTE=0..255; %PA=PACKED ARRAY[0..1] OF BYTE; %  VAR MEMREF:RECORD CASE BOOLEAN OF ,TRUE: (ADDR:INTEGER); ,FALSE:(BYTE:^PA); +END; $RPTR,INTEGER};   VAR POINT_OK:BOOLEAN;   BEGIN "WRITE(PROMPT,EOL); "POINT_OK:=FALSE; "GET_INTEGER:=TRUNC(GET_NUM(MAXVAL,MINVAL,FALSE));  END; "   (***************************************) (* PASCAL VERSION OF KEYPRESS FUNCTION *)  (* MAY NOT WORK(************************************************************)  (* GETS INTEGER NUMBER BETWEEN SPECIFIED MAX AND MIN VALUES *) (************************************************************)   FUNCTION GET_INTEGER{(PROMPT:STRING; MAXVAL,MINVAL:INTEGER):****)   FUNCTION GET_FP_NUM{(PROMPT:STRING; MAXVAL,MINVAL:REAL):REAL};   VAR POINT_OK:BOOLEAN;   BEGIN "WRITE(PROMPT,EOL); "POINT_OK:=TRUE; "GET_FP_NUM:=GET_NUM(MAXVAL,MINVAL,TRUE);  END; " GET_NUM:=FP_NUM(NUM_STR_TEMP); $  END; {GET_NUM}   (*****************************************************************)  (* GETS FLOATING PT. NUMBER BETWEEN SPECIFIED MAX AND MIN VALUES *) (*************************************************************(7)); 0WRITE(BS,' ',BS); 0DELETE(NUM_STR_TEMP,LEN+1,1); .END; *END; &END & $ELSE IF S1[1]=BS THEN &BEGIN (IF POS('.',NUM_STR_TEMP)=LEN THEN *PT_OK:=TRUE; (WRITE(BS,' ',BS); (DELETE(NUM_STR_TEMP,LEN,1); &END; & #UNTIL S1[1]=CR; WRITELN; # #(*$s+*)  unit crtutilites;   interface #var &LUNMISCINFO : file; & #procedure CURSORHOME; #procedure CURSORUP; #procedure CURSORDOWN; #procedure CURSORLEFT; #procedure CURSORRIGHT;  procedure CLEARSCREEN; #procedure CLEARLINE(LINENUMBER : ] := MISCINFO[64]; -CRTCONTROL[LEFT ] := MISCINFO[69]; -CRTCONTROL[CLEARS ] := MISCINFO[72]; -CRTCONTROL[CLEARL ] := MISCINFO[71]; -CRTCONTROL[DOWN ] := CHR(10); - -PREFIXED[LEADIN ] := false; -PREFIXED[UP ] := ODD(PREFIXCONTIXCONTROL := ORD(MISCINFO[73]); -CRTCONTROL[LEADIN ] := MISCINFO[63]; -CRTCONTROL[UP ] := MISCINFO[68]; -CRTCONTROL[RIGHT ] := MISCINFO[67]; -CRTCONTROL[ERASEEOL ] := MISCINFO[66]; -CRTCONTROL[ERASEEOS ] := MISCINFO[65]; -CRTCONTROL[HOME *ERASEOL; 'end; ' $begin (* unit initialization *) 'RESET(LUNMISCINFO,'*SYSTEM.MISCINFO'); 'MARK(HEAPPOINTER); 'NEW(INPUTPOINTER); 'with INPUTPOINTER^ do *begin * NUMOFBLOCKS := BLOCKREAD(LUNMISCINFO,MISCINFO,1); -CLOSE(LUNMISCINFO); - -PREFB := UPPERHTAB; *GOTOXY(HTAB,VTAB); *WRITE(OUTPUT,LINEOFTEXT); 'end; - $procedure PROMPT; 'begin *if VTAB < LOWERVTAB then -VTAB := LOWERVTAB *else if VTAB > UPPERVTAB then -VTAB := UPPERVTAB; *GOTOXY(0,VTAB); *WRITE(OUTPUT,PROMPTLINE); rite(1,CRTCONTROL[ERASEEOS],1) $ end; $ $procedure DISPLAY; 'begin *if VTAB < LOWERVTAB then -VTAB := LOWERVTAB *else if VTAB > UPPERVTAB then -VTAB := UPPERVTAB; *if HTAB < LOWERHTAB then -HTAB := LOWERHTAB *else if HTAB > UPPERHTAB then -HTANUMBER); (ERASEOL; %end; % #procedure ERASEOS; &begin )if LINENUMBER < LOWERVTAB then ,LINENUMBER := LOWERVTAB )else if LINENUMBER > UPPERVTAB then ,LINENUMBER := UPPERVTAB; )if PREFIXED[ERASEEOS] then ,unitwrite(1,CRTCONTROL[LEADIN],1); )unitw,unitwrite(1,CRTCONTROL[LEADIN],1); )unitwrite(1,CRTCONTROL[ERASEEOL],1); &end; # #procedure CLEARLINE; %begin (if LINENUMBER < LOWERVTAB then +LINENUMBER := LOWERVTAB (else if LINENUMBER > UPPERVTAB then +LINENUMBER := UPPERVTAB; (GOTOXY(0,LINE(1,CRTCONTROL[RIGHT],1); &end; # # #procedure CLEARSCREEN; &begin )if PREFIXED[CLEARS] then ,unitwrite(1,CRTCONTROL[LEADIN],1); )unitwrite(1,CRTCONTROL[CLEARS],1); &end; # #procedure ERASEOL; &begin )if PREFIXED[ERASEEOL] then ; &end; & #procedure CURSORLEFT; &begin )if PREFIXED[LEFT] then ,unitwrite(1,CRTCONTROL[LEADIN],1); )unitwrite(1,CRTCONTROL[LEFT],1); &end; #procedure CURSORRIGHT; &begin )if PREFIXED[RIGHT] then ,unitwrite(1,CRTCONTROL[LEADIN],1); )unitwriteocedure CURSORUP; &begin )if PREFIXED[UP] then ,unitwrite(1,CRTCONTROL[LEADIN],1); )unitwrite(1,CRTCONTROL[UP],1); &end; & #procedure CURSORDOWN; &begin )if PREFIXED[DOWN] then ,unitwrite(1,CRTCONTROL[LEADIN],1); )unitwrite(1,CRTCONTROL[DOWN],1)&PREFIXED : packed array [CRTCOMMAND] of boolean; &INPUTPOINTER: ^INPUTBUFFER; &HEAPPOINTER : ^integer; & #procedure CURSORHOME; &begin )if PREFIXED[HOME] then ,unitwrite(1,CRTCONTROL[LEADIN],1); )unitwrite(1,CRTCONTROL[HOME],1); &end; & #pr: integer; (* variable containing 8 one bit flags that * ?* determine whether or not the crt command * ?* must be prefixed by the lead in command *)  CRTCONTROL : packed array [CRTCOMMAND] of char; COMMAND = (LEADIN, UP, RIGHT, ERASEEOL, ERASEEOS, HOME, 4LEFT, CLEARS, CLEARL, DOWN); 4 &INPUTBUFFER = record 7MISCINFO : packed array[1..BLOCKSIZE] of char; 4end; 4 #var &LOWERVTAB, UPPERVTAB, &LOWERHTAB, UPPERHTAB, &NUMOFBLOCKS, &PREFIXCONTROLinteger); #procedure ERASEOL; #procedure ERASEOS(LINENUMBER : integer); #procedure DISPLAY(VTAB,HTAB : integer; LINEOFTEXT : string); #procedure PROMPT(VTAB : integer; PROMPTLINE : string); #  implementation #const &BLOC