`L i=L\Ʃx ? N'i  ͭЅ?0ȱ Ѕ?iȱi lԠԠ͠ԠϠŠͮŠ SYSTEM.APPLE   L$JN^.CODEvgPMU.TEXTr<vg PMU.PROC.TEXTvgPMU.CODEDE<vg EARTHORB.TEXTvg EARTHORB.CODEvg TRANSFER.TEXTvg  PUFFIN.TEXTvg  PUFFIN.CODEvgXTvg GRAFSTOR.CODEvg FN(VAL).TEXTvg FN(VAL).CODEvg MOVEHEAP.TEXTvg MOVEHEAP.CODEvgSPECIALCH.TEXTgLC.STARTUP.TEXTLC.STARTUP.CODE FORTFIX.TEXTvg FORTFIXLX DISASSEM.CODEvgX\ INVRSE.TEXTvg\^ INVRSE.CODEvg^b LCDSP.TEXT<vgbd LCDSP.CODE<vgdh DIRECTRY.TEXTvghj DIRECTRY.CODEvgjt RECOVER.TEXTvgtx RECOVER.CODEvgx GRAFSTOR.TEPSCAL81%  README.TEXT{  PZAP.TEXTr<vg PZAP.CODEr<vg"HIRES.ASM.TEXTg"( SWIRL.TEXT<vg(* SWIRL.CODE<vg,2 EXUTIL.TEXTvg24 EXUTIL.CODEvg4L DISASSEM.TEXTvg&꽌ɪɖ'*&%&,E'зЮ꽌ɪФ`+*xH&x'8*7Ixix&&  ') + &п x) ++`FG8`0($ p,&") (jJJ>L+ "?I>  N `  ` x V Nx .x- z `V0^*^*>` aI꽌ɪVɭ&Y&&Y& 꽌ɪ\8`&'PASCAL ANTHOLOGY 81 DISK ' #This disk contains all of the Pascal  programs and their related text files  that appeared in the 1981 issues of  Call-A.P.P.L.E. magazine.     PZAP.TEXT  PZAP.CODE - Ender !"Pascal Zap", Jan 81, pp 47-49 !"CorrRITE ', +'TO BLOCK ',BLOCK:3,SP:2); "READLN (STR); "WRITELN; "IF STR = 'YES' THEN $UNITWRITE (5,BUF,512,BLOCK,0);  END;   PROCEDURE READBLOCK;  BEGIN "WRITELN (CHR(12)); "WRITELN; "WRITELN; "WRITE ('WHICH BLOCK IS TO BE READ? '); "READLN (BLLOCK,BYTE,DEC: INTEGER; "CHOICE,CH : CHAR; "   PROCEDURE DECAHEX(I:INTEGER);  BEGIN "HEXI[0]:=HEX[I DIV 16]; "HEXI[1]:=HEX[I MOD 16];  END; "   PROCEDURE WRITEBLOCK;  BEGIN "WRITELN (CHR(12)); {clear page} "WRITELN ('RESPOND YES TO W(*$G+*)  PROGRAM PASCALZAP;   CONST SP = ' '; (HEXES = '0123456789ABCDEF'; (  VAR BUF : PACKED ARRAY [0..511] OF 0..255; (HEX : PACKED ARRAY [0..15] OF CHAR; (HEXI : PACKED ARRAY [0..1] OF CHAR; #STR, HEXSTR : STRING; "B2 N^C #   (Updated 10-AUG-84 by MC) l Memory Utility", #Jul/Aug 81, pp 43-51 #   EARTHORB.TEXT  EARTHORB.CODE - DeGroat !"PASCAL COMPUTER SIMULATIONS", #Sep 81, pp 31-38 #   TRANSFER.TEXT  PUFFIN.TEXT  PUFFIN.CODE - Dr Wo !"DOS to Pascal File Converter", #Nov/Dec 81, pp 13-42.STARTUP.TEXT  LC.STARTUP.CODE (linked) - DeGroat !"Moving the Heap", #Jun 81, pp 35-37    FORTFIX.TEXT  FORTFIX.CODE - Apple Computer Inc !"Program Fortfix", #Jun 81, pp 39 #   PMU.TEXT  PMU.PROC.TEXT  PMU.CODE (linked) - DeGroat !"Pasca GRAFSTOR.TEXT  GRAFSTOR.CODE - Trammel !"Storing Pascal Hi-Res Screens on Disk", #May 81, pp 57-59 #   FN(VAL).TEXT  FN(VAL).CODE - Berg !"Basic VAL Function in Pascal", #May 81, pp 66 #   MOVEHEAP.TEXT  MOVEHEAP.CODE  SPECIALCH.TEXT  LCe Display for Pascal 1/1", #Mar/Apr 81, pp 67 #   DIRECTRY.TEXT  DIRECTRY.CODE - Greenberg !"In the Depths of the Pascal Directory", #May 81, pp 27-28 #   RECOVER.TEXT  RECOVER.CODE - Janes !"Pascal Text Recovery", ! May 81, pp 37-40 #    DISASSEM.TEXT  DISASSEM.CODE - Rosing & McLauren !"Pascal Internals", ! Mar/Apr 81, pp 9-22 #   INVRSE.TEXT  INVRSE.CODE - DeGroat !"Inverse Text Display in Pascal", #Mar/Apr 81, pp 63 #   LCDSP.TEXT  LCDSP.CODE - DeGroat !"Lower Casect/Enhancemts", May 81, pp 60 ! !  HIRES.ASM.TEXT  SWIRL.TEXT  SWIRL.CODE (linked) - DeGroat !"Seeing Double with Pascal Graphics", #Feb 81, pp 30-33 # #  EXUTIL.TEXT  EXUTIL.CODE - Heinonen & Kotivuori !"EXEC Utility", ! Feb 81, pp 34-36 !OCK); "WRITELN; "WRITELN ('READING BLOCK ',BLOCK:3); "UNITREAD (5,BUF,512,BLOCK,0);  END;   PROCEDURE DISPLAY; "VAR ROW,COL,I,J : INTEGER;  BEGIN "ROW := 0; "J := 0; "WRITELN (CHR(12)); "REPEAT $WRITE (ROW:3,':'); $FOR COL := 0 TO 7 DO BEGIN &DECAHEX (BUF [ROW + COL]); &WRITE (HEXI:3) END; $WRITE (SP); $FOR COL := 0 TO 7 DO &IF (BUF [ROW + COL] > 31) )AND (BUF [ROW + COL] < 127) THEN (WRITE (CHR (BUF [ROW + COL])) ELSE (WRITE ('.'); $WRITELN; $ROW :=  , RESPOND YES TO WRITE צ TO BLOCK `  5P5YESׯ ` WB PASCALZA P','p':PRINT; END; "UNTIL (CHOICE='Q') OR (CHOICE='q');  END.   CHOICE: ');  END;   BEGIN {main program} "HEX:='0123456789ABCDEF'; "READBLOCK; "REPEAT #MENU; #READ(CHOICE); #WRITELN; #CASE CHOICE OF #'R','r':READBLOCK; #'W','w':WRITEBLOCK; #'D','d':DISPLAY; #'A','a':ASCIICHANGE; #'H','h':HEXCHANGE; " 'SP:5,'R)EAD BLOCK'); "WRITELN(SP:5,'W)RITE BLOCK'); "WRITELN(SP:5,'D)SPLAY BUFFER'); "WRITELN(SP:5,'A)SCII CHANGE'); "WRITELN(SP:5,'H)EX CHANGE'); "WRITELN(SP:5,'P)RINT BUFFER'); "WRITELN(SP:5,'Q)UIT'); "WRITELN; WRITELN; "WRITELN('ENTER %WRITE(P,'.'); $WRITELN(P); $ROW:=ROW+16; (* 16 COL/LINE ASSUMES *) "UNTIL ROW>511; (* 80 COL PRINTER *)  END; (*PRINT*)    PROCEDURE MENU;  BEGIN "WRITELN(CHR(12)); "WRITELN; WRITELN; "WRITELN(SP:5,'MENU OF OPTION'); "WRITELN; "WRITELN(:3); "WRITELN(P); "REPEAT $WRITE(P,ROW:3,':'); $FOR COL:=0 TO 15 DO BEGIN %DECAHEX (BUF[ROW+COL]); %WRITE(P,HEXI:3) END; $WRITE(P,SP); $FOR COL:=0 TO 15 DO $IF (BUF[ROW+COL]>31) AND '(BUF[ROW+COL]<127) THEN %WRITE(P,CHR(BUF[ROW+COL])) ELSE ,HEXSTR); &HEXADEC; &BUF[BYTE]:=DEC; &BYTE:=BYTE+1; $ END; $END; "UNTIL L=0;  END;   PROCEDURE PRINT;   VAR ROW,COL,I :INTEGER; $P :INTERACTIVE;  BEGIN "RESET(P,'PRINTER:'); "ROW:=0; "WRITELN(P,CHR(12),'BLOCK ',BLOCK; "REPEAT $DECAHEX(BUF[BYTE]); $WRITELN(BYTE:3,': ',HEXI); $WRITE (BYTE:3,': '); $READLN (HEXSTR); $WRITELN; $L:=LENGTH(HEXSTR); $IF L>2 THEN $ WRITELN('HEX VALUE TOO LONG') +ELSE $BEGIN &IF L<>0 THEN BEGIN &IF L=1 THEN & HEXSTR:=CONCAT('0' END;   PROCEDURE HEXADEC; "VAR I1,I2: INTEGER; &STR:STRING;  BEGIN "STR:=COPY(HEXSTR,2,1); "I1:=POS(STR,HEXES)-1; "STR:=COPY(HEXSTR,1,1); "I2:=POS(STR,HEXES)-1; "DEC:=I1+I2*16;  END;   PROCEDURE HEXCHANGE; "VAR L:INTEGER;  BEGIN "HEADER[BYTE] <127) THEN 'KAR:=CHR (BUF [BYTE] ) ' ELSE 'KAR:='.'; 'WRITELN (BYTE:3,': ',KAR); 'WRITE (BYTE:3,': '); 'READLN (CH); 'WRITELN ('SP-EXIT'); 'IF CH <> SP THEN )BUF [BYTE] := ORD(CH); 'BYTE := BYTE+1; "UNTIL CH=SP; READ (CH); "WRITELN  END;   PROCEDURE HEADER;  BEGIN "WRITELN (CHR(12)); "WRITE ('BYTE TO BE CHANGED? '); "READLN (BYTE); "WRITELN;  END;   PROCEDURE ASCIICHANGE; "VAR KAR:CHAR;  BEGIN "HEADER; "REPEAT " IF (BUF [BYTE] > 31) AND '(BUF ROW+8; $J := J+1; $IF J MOD 22 = 0 THEN &BEGIN (WRITELN ('BLOCK ',BLOCK:3, 1': SP-CONT; E-EXIT'); (READ (CH); (WRITELN (CHR(12)); (IF (CH='E') OR (CH='e') THEN *EXIT (DISPLAY); &END; "UNTIL ROW > 504; "WRITELN ('BLOCK ',BLOCK:3,': SP-MENU'); "HICH BLOCK IS TO BE READ? ` READING BLOCK ` `  :ȡ!ڂ  ȡDڂťڂɄڂ .áqBLOCK ` : SP-CONT; E-EXITa aEéaeÍšBLOCK `  : SP-MENU ;16-BIT ARGUMENT (LDA %1+1 (PHA (LDA %1 (PHA (.ENDM (  RETURN .EQU 00 ;STORES RETURN ADDR  (.PROC DRAWSCREEN,1 ( (POP RETURN ;SAVE RETURN ADDR (PLA (STA RETURN (PLA (STA RETURN+1 (PLA ;GET LSB (AND #01 (CMP #MOST OF THE STANDARD PASCAL  ; GRAPHIC ROUTINES.  ;  ; WRITTEN BY: RON DE GROAT 15-NOV-80  ; FEB 1981 CALL-APPLE  ;--------------------------------------  (.MACRO POP ;16-BIT ARGUMENT (PLA (STA %1 (PLA (STA %1+1 (.ENDM ( (.MACRO PUSH  ;--------------------------------------  ; LISTING #1: HI-RES PAGE SELECT RTNS  ;  ;--------------------------------------  ; THE FOLLOWING PROCEDURES ALLOW THE  ; USER TO EASILY SPECIFY WHICH HI-RES  ; SCREEN HIR WILL DISPLAY OR DRAW ON  ; WITH N^C *"B&(*,H02468:<>@TDF^JLN^RTVXZ\^jbfhjlbQébqÍ 4nj  D)SPLAY BUFFER A)SCII CHANGE H)EX CHANGE P)RINT BUFFER Q)UITצENTER CHOICE:  ץ0123456789ABCDEF bb~ z vAwn MENU OF OPTION R)EAD BLOCK W)RITE BLOCK D)SPLAY BUFFER A)SCII CHANGE H)EX `  :́1ʁ1ȡ ق  ́1ʁ1ȡBقťقɄق .šgb  _ :  P š(HEX VALUE TOO LONGDˡ?á צ0 QP_^__áT Ɓ0PRINTER: BLOCK מSP-EXITa ˡ_a__a á ,,Pצ0123456789ABCDEF ,,Pצ0123456789ABCDEF^l__ צ:  az,d  BYTE TO BE CHANGED? _ V_ť_Ʉ_._ צ: _ צ: a01 ;IS IT ODD? (BEQ PAGE ;ODD=PRIMARY (LDA #02 ;EVEN=SECONDARY (  PAGE LDY #0E (STA @0FE,Y ;STORE PAGE SELECTION (PLA ;DISCARD MSB (PUSH RETURN (LDA RETURN+1 (PHA (LDA RETURN (PHA (RTS ;RETURN TO PASCAL ( ( (.PROC DISPLAYSCREEN,1 ( (POP RETURN ;SAVE RETURN ADDR (PLA (STA RETURN (PLA (STA RETURN+1 (PLA ;GET LSB (AND #01 (EOR #01 ;REVERSE LOGIC (TAY (LDA 0C054,Y ;SELECT SCREEN (GIN &DISPLAYSCREEN(PAGE); {Select page} &FOR DELAY:=1 TO L DO; {Delay loop } &L:=1+TRUNC(L*0.98); {Reduce wait} $END; " "READLN; {wait for cr} "TEXTMODE; "GOTOXY(8,10); "WRITELN('THAT''S ALL FOLKS...');  END.   &DISTANCE:=5; {Initialize values} &ANGLE:=89; {for nextline } &CHANGE:=1; & &WHILE DISTANCE<=300 DO NEXTLINE; $END; {for loop} " "{Alternate screens for increasing speed} "L:=400; "FOR PAGE:=1 TO 150 DO $BEck} (BEGIN *FILLSCREEN(BLACK); *PENCOLOR(WHITE); (END 0ELSE {Page=2, black on white} (BEGIN *FILLSCREEN(WHITE); *PENCOLOR(BLACK); (END;  &{Select page for display} &DISPLAYSCREEN(PAGE); alize hires screen} "FOR PAGE:=1 TO 2 DO " $BEGIN &{Select page for drawing on} &DRAWSCREEN(PAGE); &PENCOLOR(NONE); {Prepare screen} &MOVETO(139,95); {before display} &TURNTO(7*PAGE); & &IF PAGE=1 THEN {White on bla }   PROCEDURE DRAWSCREEN (P:INTEGER); EXTERNAL;  PROCEDURE DISPLAYSCREEN (P:INTEGER); EXTERNAL;   PROCEDURE NEXTLINE;  BEGIN "MOVE(DISTANCE); "TURN(ANGLE); "DISTANCE:=DISTANCE+CHANGE;  END;   BEGIN {main program} " "INITTURTLE; {initi  { LISTING #2: SECOND PAGE DEMO }   PROGRAM SWIRL;   USES TURTLEGRAPHICS;   VAR DISTANCE, ANGLE, PAGE :INTEGER; (CHANGE, DELAY, L :INTEGER; (  { These two procedures select page one or }  { page two for drawing or displaying. N^CPLA ;DISCARD MSB  DONE PUSH RETURN (LDA RETURN+1 (PHA (LDA RETURN (PHA (RTS ;RETURN TO PASCAL ( (.END  jSWIRL *******************************)   CONST BUFPTRBEGIN=-16616; (* POINTER TO FIRST ACTUALIZED CHAR IN BUFFER *) &BUFPTREND=-16615; (* POINTER TO LAST ACTUALIZED CHAR IN BUFFER *) &BUFFERBEGIN=945; (* BEGINNING OF INPUT BUFFER *) &CRSGN='@'; FFER AND *)  (* SETS BUFFER-POINTERS SO THAT THESE *)  (* CHARACTERS ARE ACTUALIZED. CONSTANT *)  (* CRSGN IS CHARACTER WHICH IS REPLACED *)  (* WITH CARRIAGE RETURN. *)  (* *)  (**********PROGRAM COMMANDS;   VAR ST:STRING;   PROCEDURE COMMAND (CMDSTRING:STRING);  (*****************************************)  (* *)  (* THIS PROCEDURE TRANSFERS THE CONTENTS *)  (* OF CMDSTRING TO THE INPUT-BUN^CPAGE WHITE VIOLET WHITE1 WHITE2  H,, SWIRL.CODESWAPDISKQܡ ޢۆSWIRL.TEXT/(tT-  SWIRL.CODEK.CODE[*]^C2:SYSTEM.SWAPDISK"á{NONE BLACK ANGLE BLACK1 GREEN BLACK2  BLUE  CHANGE DISTANCEDELAY DISPLAYS DRAWSCRE L REVERSE RADAR ORANGE  s#hhh)hHH`$hhh)IThHH` H*T SWIRL.CODESWAPDISKQܡ ޢۆSWIRL.TEXT/(tT-  SWIRL.CODEK.CODE[*]^C2:SYSTEM.SWAPDISK"á{ ȡINj_á   Y,ȡǐǖ ȡ, ȡz?Hቐ THAT'S ALL FOLKS...G0 (* CHARACTER TO BE REPLACED WITH *) &  VAR OFFSET:INTEGER; (* OFFSET FROM BEGINNING OF BUFFER *) $ASCNO:INTEGER; (* ASCII CODE OF CHARACTER *)  "PROCEDURE POKE(ADDRESS,VALUE:INTEGER); "TYPE BYTE=0..255; "VAR MEMREF: (RECORD CASE INTEGER OF *1: (ADDR:INTEGER); *2: (PTR:^BYTE); (END; " "BEGIN (* POKE *) $MEMREF.ADDR:=ADDRESS; $MEMREF.PTR^:=VALUE; "END; (* POKE *) "   BEGIN (* COMMAND *) "FOR OFFSET:=1 TO LENGTH(CMDSTRING) DO $BEGIN &IF CMDSTRING[OFFSET]=):INTEGER;   VAR L,LOC:INTEGER;    FUNCTION CONV(HEX:CHAR;M:INTEGER):INTEGER;   VAR R:INTEGER;   BEGIN "R:=ORD(HEX); "IF R > 60 THEN R:=R-55 ELSE R:=R-48; "CONV:=R*M;  END;   BEGIN "LOC:=CONV(ADDR[3],1); "LOC:=LOC+CONV(ADDR[2],16); ING; $ADDS:STRING[4]; $  FUNCTION BYTEVAL(LOC:INTEGER):INTEGER;   TYPE WINDOW = PACKED ARRAY [0..0] OF 0..255;   VAR P:WINDOW; $ADR:INTEGER; $  BEGIN "ADR:=LOC; "MOVELEFT(ADR,P,2); "BYTEVAL:=P [0];  END;    FUNCTION LOCATE(ADDR:STRING3PROGRAM DISASSEM;   TYPE STRING1 = PACKED ARRAY [0..1] OF CHAR; %STRING2 = PACKED ARRAY [0..2] OF CHAR; %STRING3 = PACKED ARRAY [0..3] OF CHAR; %LN = PACKED ARRAY [0..40] OF CHAR; %  VAR I,L,SL,LL:INTEGER; $ADDR:STRING3; $DMPFIL:TEXT; $FILNM:STRN^CAP1TEXT EXUTIL.CODEz6z|z6P1b6*,, EXUTIL.CODEWAPDISK) ̅(צEXUTIL.TEXT - %̅,ړצ EXUTIL.CODE.CODE[*]~ C2:SYSTEM.SWAPDISKzRTzتP+-+-ȡ)+@á ,+,DZ+,++@@DX Z׶COMMAND STRING = PR>FAP1`b66^``Pb6r BCOMMANDS (* SET BEGIN OF BUFFER *) "POKE(BUFPTREND,LENGTH(CMDSTRING)); (* SET END OF BUFFER *)  END; (* COMMAND *)    BEGIN (* MAIN *) "WRITE('COMMAND STRING = '); "READLN(ST); "COMMAND(ST);  END. (* MAIN *)  CRSGN (THEN ASCNO:=13 (* CARRIAGE RETURN *) (ELSE ASCNO:=ORD(CMDSTRING[OFFSET]); (* ASCII VALUE OF CHAR *) &POKE(BUFFERBEGIN+OFFSET,ASCNO); (* PUT CHAR IN BUFFER *) $END; "POKE(BUFPTRBEGIN,0); "LOC:=LOC+CONV(ADDR[1],256); "L:=CONV(ADDR[0],1); "IF L>7 THEN "BEGIN $L:=(L-8)*4096; $LOC:=LOC+L-32760-8; "END "ELSE LOC:=LOC+L*4096; "LOCATE:=LOC;  END;    PROCEDURE HEX(DEC:INTEGER;VAR HEXD:STRING1);   VAR UPR,LWR:INTEGER;   BEGIN "UPR:=DEC DIV 16; "LWR:=DEC MOD 16; "IF UPR>= 10 THEN UPR:=UPR+55 ELSE UPR:=UPR+48; "IF LWR>= 10 THEN LWR:=LWR+55 ELSE LWR:=LWR+48; "HEXD[0]:=CHR(UPR); "HEXD[1]:=CHR(LWR);  END;    PROCEDURE DRES(LOC:INTEGER;VAR ADRS:STRING3);   VAR HB,LB:IN:BEGIN S:='ROL';P:=1;I:= 1;END; "'3':BEGIN S:='ROL';P:=1;I:= 2;END; "'4':BEGIN S:='LSR';P:=1;I:= 1;END; "'5':BEGIN S:='LSR';P:=1;I:= 2;END; "'6':BEGIN S:='ROR';P:=1;I:= 1;END; "'7':BEGIN S:='ROR';P:=1;I:= 2;END; "'8':BEGIN S:='STX';P:=1;I:= 1;END; "D; "'E':BEGIN S:='SBC';P:=1;I:= 1;END; "'F':BEGIN S:='SBC';P:=1;I:= 2;END; "END;  END;    PROCEDURE SIX (CH:CHAR;VAR P,I:INTEGER;VAR S:STRING2);  BEGIN "CASE CH OF "'0':BEGIN S:='ASL';P:=1;I:= 1;END; "'1':BEGIN S:='ASL';P:=1;I:= 2;END;  '2'"'7':BEGIN S:='ADC';P:=1;I:= 2;END; "'8':BEGIN S:='STA';P:=1;I:= 1;END; "'9':BEGIN S:='STA';P:=1;I:= 2;END; "'A':BEGIN S:='LDA';P:=1;I:= 1;END; "'B':BEGIN S:='LDA';P:=1;I:= 2;END; "'C':BEGIN S:='CMP';P:=1;I:= 1;END; "'D':BEGIN S:='CMP';P:=1;I:= 2;EN;END; "'1':BEGIN S:='ORA';P:=1;I:= 2;END; "'2':BEGIN S:='AND';P:=1;I:= 1;END; "'3':BEGIN S:='AND';P:=1;I:= 2;END; "'4':BEGIN S:='EOR';P:=1;I:= 1;END; "'5':BEGIN S:='EOR';P:=1;I:= 2;END; "'6':BEGIN S:='ADC';P:=1;I:= 1;END; P:=1;I:= 1;END; "'B':BEGIN S:='LDY';P:=1;I:= 2;END; "'C':BEGIN S:='CPY';P:=1;I:= 1;END; "'E':BEGIN S:='CPX';P:=1;I:= 1;END; "END;  END;    PROCEDURE FIVE(CH:CHAR;VAR P,I:INTEGER;VAR S:STRING2);  BEGIN "CASE CH OF "'0':BEGIN S:='ORA';P:=1;I:= 1  PROCEDURE FOUR(CH:CHAR;VAR P,I:INTEGER;VAR S:STRING2);  BEGIN "CASE CH OF "'0','1','3','4','5','6','7','D','F':NOP; "'2':BEGIN S:='BIT';P:=1;I:= 1;END; "'8':BEGIN S:='STY';P:=1;I:= 1;END; "'9':BEGIN S:='STY';P:=1;I:= 2;END; "'A':BEGIN S:='LDY';"'F':BEGIN S:='SBC';P:=1;I:= 9;END; "END;  END;    PROCEDURE TWO (CH:CHAR;VAR P,I:INTEGER;VAR S:STRING2);  BEGIN "CASE CH OF "'0','1','2','3','4','5','6','7','8','9','B','C','D','E','F':NOP; "'A':BEGIN S:='LDX';P:=1;I:= 0;END; "END;  END;  8;END; "'9':BEGIN S:='STA';P:=1;I:= 9;END; "'A':BEGIN S:='LDA';P:=1;I:= 8;END; "'B':BEGIN S:='LDA';P:=1;I:= 9;END; "'C':BEGIN S:='CMP';P:=1;I:= 8;END; "'D':BEGIN S:='CMP';P:=1;I:= 9;END; "'E':BEGIN S:='SBC';P:=1;I:= 8;END; ND; "'2':BEGIN S:='AND';P:=1;I:= 8;END; "'3':BEGIN S:='AND';P:=1;I:= 9;END; "'4':BEGIN S:='EOR';P:=1;I:= 8;END; "'5':BEGIN S:='EOR';P:=1;I:= 9;END; "'6':BEGIN S:='ADC';P:=1;I:= 8;END; "'7':BEGIN S:='ADC';P:=1;I:= 9;END; "'8':BEGIN S:='STA';P:=1;I:= =1;I:=10;END; "'E':BEGIN S:='CPX';P:=1;I:= 0;END; "'F':BEGIN S:='BEQ';P:=1;I:=10;END; "END;  END;    PROCEDURE ONE (CH:CHAR;VAR P,I:INTEGER;VAR S:STRING2);  BEGIN "CASE CH OF "'0':BEGIN S:='ORA';P:=1;I:= 8;END; "'1':BEGIN S:='ORA';P:=1;I:= 9;E"'6':BEGIN S:='RTS';P:=0;I:=11;END; "'7':BEGIN S:='BVS';P:=1;I:=10;END; "'8':NOP; "'9':BEGIN S:='BCC';P:=1;I:=10;END; "'A':BEGIN S:='LDY';P:=1;I:= 0;END; "'B':BEGIN S:='BCS';P:=1;I:=10;END; "'C':BEGIN S:='CPY';P:=1;I:= 0;END; "'D':BEGIN S:='BNE';P:"'0':BEGIN S:='BRK';P:=0;I:=11;END; "'1':BEGIN S:='BPL';P:=1;I:=10;END; "'2':BEGIN S:='JSR';P:=2;I:= 4;END; "'3':BEGIN S:='BMI';P:=1;I:=10;END; "'4':BEGIN S:='RTI';P:=0;I:=11;END; "'5':BEGIN S:='BVC';P:=1;I:=10;END; "ADRS[2]:=CD2[0]; "ADRS[3]:=CD2[1];  END;    PROCEDURE OPCODE(CD:STRING1;VAR P,I:INTEGER;VAR S:STRING2);   PROCEDURE NOP;  BEGIN "S:='NOP';P:=0;I:=11;  END;    PROCEDURE ZERO(CH:CHAR;VAR P,I:INTEGER;VAR S:STRING2);  BEGIN "CASE CH OF TEGER; $CD1,CD2:STRING1; $  BEGIN "IF LOC>0 THEN "BEGIN $HB:=LOC DIV 256; $LB:=LOC MOD 256; "END "ELSE BEGIN $LOC:=LOC+32761+7; $HB:=LOC DIV 256 + 128; $LB:=LOC MOD 256; "END; "HEX(HB,CD1); "HEX(LB,CD2); "ADRS[0]:=CD1[0]; "ADRS[1]:=CD1[1];'9':BEGIN S:='STX';P:=1;I:= 2;END; "'A':BEGIN S:='LDX';P:=1;I:= 1;END; "'B':BEGIN S:='LDX';P:=1;I:= 2;END; "'C':BEGIN S:='DEC';P:=1;I:= 1;END; "'D':BEGIN S:='DEC';P:=1;I:= 2;END; "'E':BEGIN S:='INC';P:=1;I:= 1;END; "'F':BEGIN S:='INC';P:=1;I:= 2;END; "END;  END;    PROCEDURE EGHT(CH:CHAR;VAR P,I:INTEGER;VAR S:STRING2);  BEGIN "CASE CH OF "'0':BEGIN S:='PHP';P:=0;I:=11;END; "'1':BEGIN S:='CLC';P:=0;I:=11;END; "'2':BEGIN S:='PLP';P:=0;I:=11;END; "'3':BEGIGIN S:='INC';P:=2;I:=4;END; "'F':BEGIN S:='INC';P:=2;I:=5;END; "END;  END; { Cases }    BEGIN "CASE CD[1] OF "'0':ZERO(CD[0],P,I,S); "'1':ONE(CD[0],P,I,S); "'2':TWO(CD[0],P,I,S); "'3','7','B','F':NOP; "'4':FOUR(CD[0],P,I,S); "'5':FIVE(CD[0],':BEGIN S:='ROR';P:=2;I:=5;END; "'8':BEGIN S:='STX';P:=2;I:=4;END; "'9':BEGIN S:='STX';P:=2;I:=5;END; "'A':BEGIN S:='LDX';P:=2;I:=4;END; "'B':BEGIN S:='LDX';P:=2;I:=5;END; "'C':BEGIN S:='DEC';P:=2;I:=4;END; "'D':BEGIN S:='DEC';P:=2;I:=5;END; "'E':BE"'0':BEGIN S:='ASL';P:=2;I:=4;END; "'1':BEGIN S:='ASL';P:=2;I:=5;END; "'2':BEGIN S:='ROL';P:=2;I:=4;END; "'3':BEGIN S:='ROL';P:=2;I:=5;END; "'4':BEGIN S:='LSR';P:=2;I:=4;END; "'5':BEGIN S:='LSR';P:=2;I:=5;END; "'6':BEGIN S:='ROR';P:=2;I:=4;END; "'7I:=5;END; "'C':BEGIN S:='CMP';P:=2;I:=4;END; "'D':BEGIN S:='CMP';P:=2;I:=5;END; "'E':BEGIN S:='SBC';P:=2;I:=4;END; "'F':BEGIN S:='SBC';P:=2;I:=5;END; "END;  END;    PROCEDURE EEEE(CH:CHAR;VAR P,I:INTEGER;VAR S:STRING2);  BEGIN "CASE CH OF :=2;I:=4;END; "'5':BEGIN S:='EOR';P:=2;I:=5;END; "'6':BEGIN S:='ADC';P:=2;I:=4;END; "'7':BEGIN S:='ADC';P:=2;I:=5;END; "'8':BEGIN S:='STA';P:=2;I:=4;END; "'9':BEGIN S:='STA';P:=2;I:=5;END; "'A':BEGIN S:='LDA';P:=2;I:=4;END; "'B':BEGIN S:='LDA';P:=2; END;    PROCEDURE DDDD(CH:CHAR;VAR P,I:INTEGER;VAR S:STRING2);  BEGIN "CASE CH OF "'0':BEGIN S:='ORA';P:=2;I:=4;END; "'1':BEGIN S:='ORA';P:=2;I:=5;END; "'2':BEGIN S:='AND';P:=2;I:=4;END; "'3':BEGIN S:='AND';P:=2;I:=5;END; "'4':BEGIN S:='EOR';P"'2':BEGIN S:='BIT';I:=4;END; "'4':BEGIN S:='JMP';I:=4;END; "'6':BEGIN S:='JMP';I:=7;END; "'8':BEGIN S:='STY';I:=4;END; "'A':BEGIN S:='LDY';I:=4;END; "'B':BEGIN S:='LDY';I:=5;END; "'C':BEGIN S:='CPY';I:=4;END; "'E':BEGIN S:='CPX';I:=4;END; "END; BEGIN S:='TAX';P:=0;I:=11;END; "'B':BEGIN S:='TSX';P:=0;I:=11;END; "'C':BEGIN S:='DEX';P:=0;I:=11;END; "END;  END;    PROCEDURE CCCC(CH:CHAR;VAR P,I:INTEGER;VAR S:STRING2);  BEGIN "P:=2; "CASE CH OF "'0','1','3','5','7','9','D','F':NOP; 3','5','7','D','E','F':NOP; "'0':BEGIN S:='ASL';P:=0;I:=12;END; "'2':BEGIN S:='ROL';P:=0;I:=12;END; "'4':BEGIN S:='LSR';P:=0;I:=12;END; "'6':BEGIN S:='ROR';P:=0;I:=12;END; "'8':BEGIN S:='TXA';P:=0;I:=11;END; "'9':BEGIN S:='TXS';P:=0;I:=11;END; "'A':D; "'C':BEGIN S:='CMP';P:=1;I:= 0;END; "'D':BEGIN S:='CMP';P:=2;I:= 6;END; "'E':BEGIN S:='SBC';P:=1;I:= 0;END; "'F':BEGIN S:='SBC';P:=2;I:= 6;END; "END;  END;    PROCEDURE AAAA(CH:CHAR;VAR P,I:INTEGER;VAR S:STRING2);  BEGIN "CASE CH OF "'1','"'5':BEGIN S:='EOR';P:=2;I:= 6;END; "'6':BEGIN S:='ADC';P:=1;I:= 0;END; "'7':BEGIN S:='ADC';P:=2;I:= 6;END; "'8':BEGIN S:='STA';P:=1;I:= 0;END; "'9':BEGIN S:='STA';P:=2;I:= 6;END; "'A':BEGIN S:='LDA';P:=1;I:= 0;END; "'B':BEGIN S:='LDA';P:=2;I:= 6;ENHAR;VAR P,I:INTEGER;VAR S:STRING2);  BEGIN "CASE CH OF "'0':BEGIN S:='ORA';P:=1;I:= 0;END; "'1':BEGIN S:='ORA';P:=2;I:= 6;END; "'2':BEGIN S:='AND';P:=1;I:= 0;END; "'3':BEGIN S:='AND';P:=2;I:= 6;END; "'4':BEGIN S:='EOR';P:=1;I:= 0;END; EGIN S:='TAY';P:=0;I:=11;END; "'B':BEGIN S:='CLV';P:=0;I:=11;END; "'C':BEGIN S:='INY';P:=0;I:=11;END; "'D':BEGIN S:='CLD';P:=0;I:=11;END; "'E':BEGIN S:='INX';P:=0;I:=11;END; "'F':BEGIN S:='SED';P:=0;I:=11;END; "END;  END;    PROCEDURE NINE(CH:CN S:='SEC';P:=0;I:=11;END; "'4':BEGIN S:='PHA';P:=0;I:=11;END; "'5':BEGIN S:='CLI';P:=0;I:=11;END; "'6':BEGIN S:='PLA';P:=0;I:=11;END; "'7':BEGIN S:='SEI';P:=0;I:=11;END; "'8':BEGIN S:='DEY';P:=0;I:=11;END; "'9':BEGIN S:='TYA';P:=0;I:=11;END; "'A':BP,I,S); "'6':SIX(CD[0],P,I,S); "'8':EGHT(CD[0],P,I,S); "'9':NINE(CD[0],P,I,S); "'A':AAAA(CD[0],P,I,S); "'C':CCCC(CD[0],P,I,S); "'D':DDDD(CD[0],P,I,S); "'E':EEEE(CD[0],P,I,S); "END;  END; { Opcode }    PROCEDURE DECODE(VAR LOC:INTEGER);   VAR VAL,PRM,INDX:INTEGER; $CODE:STRING1; $SSM:STRING2; $ADDR:STRING3; $LINE:LN;   BEGIN "FOR VAL:=0 TO 39 DO LINE[VAL]:=' '; "DRES(LOC,ADDR); "FOR VAL:=0 TO 3 DO LINE[VAL+1]:=ADDR[VAL]; "HEX(BYTEVAL(LOC),CODE); "LINE[6]:=CODE[0]; "LINE[7]:=C0F. "qbSD9 T ۹GLDXר60F.!#%')+-/ ";ACEGIV ۹{BITרSTYSTYרzLDYiLDYרXCPORA ANDרAND EORרEOR ADCרADC STAרSTA LDAרLDA yCMPרhCMP WSBCרFSBC 5 RTSר BVS BCCר LDYBCSר zCPYiBNEר XCPXGBEQר 60F.  "rcTE: H ۹ORAרBšǀvNOP ۹BRKר BPL JSRרBMI RTIר BVC<š70ڏ"ڨšނ r ġ70 ġ70ۿڿBjDISASSEM '); "RDIN; "LL:=LOCATE(ADDR); "L:=SL; "REPEAT $DECODE(L); $L:=L+1; "UNTIL L>LL; "CLOSE(DMPFIL,LOCK); "DISASSEM;  END. {main}  " DDR[L]:=ADDR[L+1];  END;    BEGIN {main program} "WRITE(' STARTING ADDRESS IN HEX? '); "RDIN; "IF ADDR[0] = 'Q' THEN EXIT(DISASSEM); "FILNM:=CONCAT('PSCPLFR:',ADDS,'.TEXT'); "REWRITE(DMPFIL,FILNM); "SL:= LOCATE(ADDR); "WRITE(' ENDING ADDRESS? IN )VAL:=BYTEVAL(LOC); )IF VAL>27 THEN VAL:=VAL-256; )DRES(LOC+VAL+1,ADDR); )FOR VAL:=0 TO 3 DO LINE[22+VAL]:=ADDR[VAL]; 'END;  END; "WRITELN(DMPFIL,LINE);  END;    PROCEDURE RDIN;  BEGIN "ADDS:=' '; "READLN(ADDS); "FOR L:=0 TO 3 DO A(LINE[24]:=LINE[13]; (LINE[25]:=LINE[9]; (LINE[26]:=LINE[10]; &END; $8,9:BEGIN *LINE[22]:='@'; *LINE[23]:=LINE[9]; *LINE[24]:=LINE[10]; *LINE[25]:=','; *CASE INDX OF *8:LINE[26]:='X'; *9:LINE[26]:='Y'; *END; (END; $12:LINE[22]:='A'; $10:BEG ,LINE[22]:=LINE[12]; ,LINE[23]:=LINE[13]; ,LINE[24]:=LINE[9]; ,LINE[25]:=LINE[10]; ,LINE[26]:=','; ,CASE INDX OF ,4:LINE[26]:=' '; ,5:LINE[27]:='X'; ,6:LINE[27]:='Y'; ,END; *END; " 7:BEGIN (LINE[22]:='@'; (LINE[23]:=LINE[12]; BEGIN (LINE[22]:='#'; (LINE[23]:=LINE[9]; (LINE[24]:=LINE[10]; &END; $1,2,3:BEGIN ,LINE[22]:=LINE[9]; ,LINE[23]:=LINE[10]; ,LINE[24]:=','; ,CASE INDX OF ,1:LINE[24]:=' '; ,2:LINE[25]:='X'; ,3:LINE[25]:='Y'; ,END; " END; " 4,5,6:BEGINODE[1]; "OPCODE(CODE,PRM,INDX,SSM); "VAL:=0; "WHILE PRM>0 DO "BEGIN $LOC:=LOC+1; $HEX(BYTEVAL(LOC),CODE); $LINE[9+VAL]:=CODE[0]; $LINE[10+VAL]:=CODE[1]; $VAL:=3; $PRM:=PRM-1; "END; "FOR VAL:=0 TO 2 DO LINE[17+VAL]:=SSM[VAL]; "CASE INDX OF $0:YGCPXר60F.~o "n_PC ۹ORAרORAANDרANDEORרEORADCרADCSTAרSTALDAרLDAyCMPרhCMPWSBCרFSBC50F. "qbSD9 T ۹ASLרASLROLרROLš   :. > lH\D,n (Adšۂȡ ۂ(! ^`b^l )) 7X$k<_ ת_ȡLץ 5 STARTING ADDRESS IN HEX? Qá6bbPSCPLFR:b_ b.TEXTbP 6 ENDING ADDRESS? ( ( ( ( (@ ( ( ( ( (,ٹ (X (Y  n (Adšۂȡ ۂ(! ^`b^l )) 7X$k< ( ( ( ( ( ( ( (,ٹ ( ! (X (Y % ( ( ( ( ( ( ( ( (,ٹ ( ! (X (Y % (@ ( ( ( ( @: 'ȡ ( ȡ ( ( (š: ۂ( ۂ(ȡ ۂ(ٹ (# ( SD9 Tۨ     |n`RD60F.vl` "bXLLSRרLSRRORרRORSTXרSTXLDXרLDXyDECרhDECWINCרFINC50F. "qbSTALDAרLDAyCMPרhCMPWSBCרFSBC50F. "qbSD9 T۹ASLרASLROLרROLRCPYDCPX60F.|~|rh^ "bVJ@۹ORAרORAANDרANDEORרEORADCרADCSTAרR TXAר zTXS iTAXר XTSX GDEXר 60F.zm^ "]N?: ۹tBITJMPJMP|STYnLDY`LDYSTALDAרLDAyCMPרhCMPWSBCרFSBC50F. "qbSD9 T۹ASLר ROL LSRר ROWINXר FSED 50F. "qbSD9 T۹ORAרORAANDרANDEORרEORADCרADCSTAר٭9 T۹PHPר CLC PLPר SEC PHAר CLI PLAר SEI DEYר TYA TAYר CLV yINYר hCLD LSRרLSRRORרRORSTXרSTXLDXרLDXyDECרhDECWINCרFINC50F. "qbSD_ ת_ȡLץ 5 STARTING ADDRESS IN HEX? Qá6bbPSCPLFR:b_ b.TEXTbP 6 ENDING ADDRESS? N^CN^CAP1TEXT INVRSE.CODEz6z|z6P1b6*,, INVRSE.CODEWAPDISKINVRSE.TEXT INVRSE.CODE.CODE[*]C2:SYSTEM.SWAPDISKTHIS IS NORMALTHIS IS INVERSEצTHIS IS lower AND UPPER CASEצAND THIS IS NORMAL AGAIN`b66^``Pb6rBINVERSED ) "WRITELN(INVERSE,'THIS IS INVERSE');   (* LOWER CASE IS NORMAL *) "WRITELN('THIS IS lower AND UPPER CASE'); "  (* CTRL-T RESETS TO NORMAL MODE *) "WRITE(NORMAL,'AND THIS IS NORMAL AGAIN');   END.  PROGRAM INVERSEDEMO;   (* WORKS ONLY UNDER PASCAL 1.1 *)   VAR INVERSE,NORMAL:CHAR;   BEGIN "INVERSE := CHR(18); (* CTRL-R *) "NORMAL := CHR(20); (* CTRL-T *) " "WRITELN(NORMAL,'THIS IS NORMAL'); "  (* CTRL-R SETS PSEUDO UPPER CASE MODE *PROGRAM LCDISPLAY;  (************************************)  (* THIS PROGRAM MODIFIES BIOS SO *)  (* THAT TRUE LOWER CASE DISPLAY IS *)  (* POSSIBLE WITH A LOWER CASE *)  (* ADAPTER AND PASCAL VER 1.1. *)  (* [BYTE+1]; "WRITELN('NEXT OPEN BLOCK: ',VALUE); "PERCENT:=ROUND(((VALUE-6)*100)/274); "WRITELN('DISK IS ',PERCENT,'% FULL');  END.  :=(BUFFER[20] MOD 16); "YR:=BUFFER[21] DIV 2; "WRITELN(MO,'/',DA,'/',YR); "BYTE:=BUFFER[16]*26+2; "IF BYTE>510 THEN $BEGIN &BLOCK:=BYTE DIV 512 +2; &BYTE:=BYTE MOD 512; &UNITREAD(VOLUME,BUFFER,512,BLOCK,0); $END; "VALUE:=BUFFER[BYTE] + 256*BUFFERPROGRAM DIRECTORY;   VAR VALUE,BYTE,PERCENT,VOLUME, (DA,MO,YR,BLOCK :INTEGER;  BUFFER:PACKED ARRAY[0..511] OF 0..255; (  BEGIN "VOLUME:=4; "BLOCK:=2; "UNITREAD(VOLUME,BUFFER,512,BLOCK,0); "DA:=(BUFFER[20] DIV 16)+(BUFFER[21] MOD 2)*16; "MON^wAP1TEXT LCDSP.CODEz6z|z6P1b6*,, LCDSP.CODESWAPDISK) ̅(צLCDSP.TEXT - %̅,ړצLis LCDSP.CODEK.CODE[*]C2:SYSTEM.SWAPDISK.ץ1צ SYSTEM.APPLEǫǬǮT 6rBLCDISPLA PPER CASE*) " "BLT:=BLOCKWRITE(S,BLK,1,BLN); " "CLOSE(S,LOCK);   END.  LK[171]:=234; (*REPLACE UC CONVERSION*) "BLK[172]:=234; (*WITH NOP*) "BLK[174]:=127; (*CHANGE CHAR MASK*) " "BLT:=BLOCKWRITE(S,BLK,1,BLN); " "BLN:=23; "BLT:=BLOCKREAD(S,BLK,1,BLN); " "BLK[252]:=0; (*ELIMINATE PSEUDO-U *)  (* WRITTEN BY: RON DE GROAT 1/9/80 *)  (************************************)   VAR BLK:PACKED ARRAY[0..511] OF 0..255; $BLT, $BLN:INTEGER; $S:FILE; $   BEGIN "RESET(S,'SYSTEM.APPLE'); "BLN:=5; "BLT:=BLOCKREAD(S,BLK,1,BLN); " "BTDIRECTOR INTABLE CHARACTERS'); (CH:= PROMPT ('SELECTION? ', ['A','F']); (IF CH = 'F' +THEN RSLT:= TRUE +ELSE RSLT:= FALSE %END; (*GETPRNTOPTION*) % % "PROCEDURE INITIALIZE (VAR PRNTSET: CHARSET; VAR INDEV: INMODE; 8VAR OUTDEV: OUTMODE; VAR FILTER: BOOLEAN)NUM) %END; (*WRITEBLOCK*) " " "PROCEDURE GETPRNTOPTION (VAR RSLT: BOOLEAN); % %VAR CH: CHAR; % %BEGIN (WRITELN; (WRITE ('THE OUTPUT PRINT OPTIONS ARE'); (WRITE (' A)LL CHARACTERS PRINTED, USING ORD WHEN NEEDED'); (WRITE (' F)ILTER OUT NONPR1 FOR I:= 0 TO 511 DO 4BEGIN 7TEMP:= BLOCKARRAY [I]; 7IF TEMP IN PRINTSET :THEN WRITE (OUTFILE, TEMP) :ELSE WRITE (OUTFILE, '[', ORD(TEMP), ']') 4END (*I LOOP*) 1END; )IF OUTDEVICE <> DISC ,THEN WRITELN (OUTFILE,CHR(13),'END OF BLOCKNUMBER ',BLK(13)); 1WRITELN (OUTFILE, 'BLOCKNUMBER ', BLKNUM); 1WRITELN (OUTFILE); /END; )IF FILTRATION ,THEN BEGIN 3FOR I:= 0 TO 511 DO 4BEGIN 7TEMP:= BLOCKARRAY [I]; 7IF TEMP IN PRINTSET 9THEN WRITE (OUTFILE, TEMP) 4END (*I LOOP*) 1END ,ELSE BEGIN SET; ,IF NOT GOOD THEN /WRITE (CHR(7)); )UNTIL GOOD; )PROMPT:= CH; &END; # # #PROCEDURE WRITEBLOCK (BLKNUM: INTEGER; VAR BLOCKARRAY:BLOCK); & &VAR I : INTEGER; *TEMP: CHAR; * &BEGIN )IF OUTDEVICE <> DISC ,THEN BEGIN 1WRITELN (OUTFILE, CHR: INMODE; 'OUTFILE : TEXT; 'PRINTSET : SET OF CHAR; ' # #FUNCTION PROMPT (S:STRING; OKSET:CHARSET):CHAR; # # VAR GOOD: BOOLEAN; * CH: CHAR; , &BEGIN )REPEAT ,WRITELN; ,WRITE (S); ,READ (CH); ,WRITELN; ,UNITCLEAR (1); ,GOOD:= CH IN OKPROGRAM RECOVER;   TYPE OUTMODE = (PRNTR, CONSL, DISC); (INMODE = 4..5; (BLOCK = PACKED ARRAY [0..511] OF CHAR; (CHARSET = SET OF CHAR; ( #VAR START,STOP: INTEGER; 'AGAIN : CHAR; 'FILTRATION: BOOLEAN; 'OUTDEVICE : OUTMODE; 'INDEVICE N^ǤdDISK IS  % FULLL6*,, DIRECTRY.CODEPDISKDIRECTRY.TEXT DIRECTRY.CODEODE[*]C2:SYSTEM.SWAPDISK      / /   š    NEXT OPEN BLOCK:  B; % %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 ', =['P','C','D']); (CASE SELECTION OF +'P':BEGIN 2PRNTSET:= [' '..']',CHR(13)]; 2REWRITE (OUTFILE, 'PRINTER:'); 2OUTDEV:= PRNTR; 2GETPRNTOPTION (FILTER) /END; +'C':BEGIN 2PRNTSET:= [' '..']',CHR(13)]; 2REWRITE (OUTFILE, 'CONSOLE:'); % OUTDEV:= CONSL; ʁ-ȡá . START AT BLOCK ?  NUMBER OF BLOCKS? (1.. )  ڂץ 56z ? צCONSOLE:F ?$CP^, &@ábצ SAVE AS? ƁPƁ́-Ɓ-ƁPƁ-צ.TEXTUƁ-P Ɓ́- CHARACTERS SELECTION? ׳BFáצDISC UNIT TO BE READ (4..5)? 04áצ$OUTPUT TO P)RINTER C)ONSOLE D)ISC ݹ ? צPRINTER: [ ]ˡ7  END OF BLOCKNUMBER   THE OUTPUT PRINT OPTIONS ARE1 A)LL CHARACTERS PRINTED, USING ORD WHEN NEEDEDצ& F)ILTER OUT NONPRINTABLEP>&>== =>LV& Zˡ>   BLOCKNUMBER   3ȡ$ۥ6 NȡAۥ6 BhRECOVER ION); #REPEAT &GETRANGE (START, STOP); &PROCESSBLOCKS (START, STOP); &AGAIN:= PROMPT ('PROCESS ANOTHER RANGE OF BLOCKS? ', 7['Y','N']); #UNTIL AGAIN = 'N';  END. % 1 (WRITE ('START AT BLOCK ? '); (READLN (FIRST); (MAX:= 280 - FIRST; (WRITELN ('NUMBER OF BLOCKS? (1..',MAX,') '); (READLN (NUM); (LAST:= FIRST + NUM -1 %END; (*GETRANGE*) % %  BEGIN (*MAIN PGM*) #INITIALIZE (PRINTSET, INDEVICE, OUTDEVICE, FILTRATNUM); .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; LOCK; )F : STRING; ) %BEGIN (IF OUTDEVICE = DISC +THEN BEGIN 3WRITELN; 3WRITE ('SAVE AS? '); 3READLN (F); 3F:= CONCAT (F, '.TEXT'); 3REWRITE (OUTFILE, F) 0END; (FOR BLOCKNUM:= FIRST TO LAST DO +BEGIN .UNITREAD (INDEVICE,BUFFER,512,BLOCK2GETPRNTOPTION (FILTER) /END; +'D':BEGIN 2PRNTSET:= [' '..']',CHR(13),CHR(16)]; 2OUTDEV:= DISC; 2FILTER:= TRUE /END (END (*CASE*) %END; (*INITIALIZE*) % % "PROCEDURE PROCESSBLOCKS (FIRST, LAST: INTEGER); % %VAR BLOCKNUM: INTEGER; )BUFFER : B!PROCESS ANOTHER RANGE OF BLOCKS? ׳@Ná Stz"^, &@ábצ SAVE AS? ƁPƁ́-Ɓ-ƁPƁ-צ.TEXTUƁ-P Ɓ́-N^Ǥ$READ(KEYBOARD,COMMAND); $CASE COMMAND OF &'T' : TEXTMODE; &'G' : GRAFMODE; &'C' : INITTURTLE; &'M' : MAKEGRAPH; &'S' : PUTSCREEN; &'R' : GETSCREEN; $END; "UNTIL COMMAND = 'Q'; "TEXTMODE  END.  DDRESS := SCREENSTART; (* SET POINTER TO START OF GRAPHICS PAGE *) " "INITTURTLE; (* CLEAR THE GRAPHICS SCREEN AND RETURN *) "TEXTMODE; (* THE SCREEN TO TEXT MODE *) " "REPEAT $PROMPTLINE; "WRITELN('INPUT FILE NAME TO GET SCREEN FROM'); "READLN(ALBUM); " "RESET(SCREENS,ALBUM); "GET(SCREENS); "GRAFPAGE.POINTER^ := SCREENS^; (* PRINCIPAL STATEMENT FOR SCREEN RECALL *) "CLOSE(SCREENS)  END;    BEGIN (*MAIN ROUTINE*)  "GRAFPAGE.A;   (* THIS ROUTINE MOVES A HIGH RESOLUTION IMAGE FROM DISK STORAGE INTO *)  (* THE 8 KILOBYTE APPLE HIGH RESOLUTION MEMORY REGION. POINTERS *)  (* MAKE THIS A SIMPLE TO DO JOB *)   BEGIN "PAGE(OUTPUT); PAGE(OUTPUT); "WRITELN('INPUT FILE NAME TO STORE SCREEN IN'); "READLN(ALBUM); " "REWRITE(SCREENS,ALBUM); " "SCREENS^ := GRAFPAGE.POINTER^; (*THIS IS THE KEY SAVING STATEMENT *) "PUT(SCREENS); "CLOSE(SCREENS,LOCK)  END;    PROCEDURE GETSCREENCEDURE PUTSCREEN;   (* THIS PROCEDURE IS USED TO TRANSFER A HIGH RESOLUTION IMAGE FROM *)  (* APPLE'S HIGH RESOLUTION MEMORY TO AN 8 KILOBYTE ELEMENT OF A DISK *)  (* FILE. SIMPLE POINTER ASSIGNMENTS MAKE THIS QUICK AND SIMPLE *)   BEGIN "   PROCEDURE MAKEGRAPH;   (* THIS PROCEDURE GENERATES A RANDOM LINE DRAWING IN HIGH RESOLUTION *)   VAR (I : INTEGER; (  BEGIN "RANDOMIZE; "PENCOLOR(REVERSE); "FOR I:= 1 TO 200 DO $MOVETO(RANDOM MOD 279,RANDOM MOD 190);  END;    PROPLACES A COMMAND PROMPT AT SCREEN POSITION (0,0) *)   CONST (PROMPTX = 0; (PROMPTY = 0; (  BEGIN "GOTOXY(PROMPTX,PROMPTY); "WRITELN('COMMAND:M)AKE A GRAPH,S)TORE,R)ECALL,T)EXTMODE,G)RAFMODE'); "WRITELN(' C)LEAR SCREEN,Q)UIT')  END; ); ;TRUE : (POINTER:^SCREENTYPE); 7 7END; (SCREENFILE = FILE OF SCREENTYPE; ( (  VAR (GRAFPAGE : SCREENHOOK; (SCREENS : SCREENFILE; (ALBUM : STRING[20]; (COMMAND : CHAR; ( (  PROCEDURE PROMPTLINE;   (* THIS ROUTINE *)    CONST (SCREENSTART = 8192; (SCREENLENGTH = 8191; ( (  TYPE (BYTE = 0..255; (SCREENTYPE = PACKED ARRAY[0..SCREENLENGTH] OF BYTE; (SCREENHOOK = RECORD ) 9CASE BOOLEAN OF ;FALSE : (ADDRESS:INTEGERPROGRAM GRAFSTORE;  USES APPLESTUFF, TURTLEGRAPHICS;   (* THIS PROGRAM DEMONSTRATES A TECHNIQUE *)  (* FOR STORING AND RECALLING HIGH *)  (* RESOLUTION PAGES TO AND FROM DISK *)  (* STORAGE UNDER COMPLETE PASCAL PROGRAM *)  (* CONTROL GRAFSTOR  BASIC H:=OPER[I]; *IF CH ='-' THEN VL:=-VL; !END; !  BEGIN END.  (VAL); #FOR I:= 1 TO IL DO # BEGIN &CH:= OPER[I]; &IF NOT (CH IN NUM) (THEN I:=IL+1 (ELSE *IF (CH <> '.') AND (CH <> '-') AND (CH <> '+') ,THEN VL:=VL*10 + ORD(CH)-48; $END; #IF POS('.',OPER) > 0 %THEN VL:=VL/PWROFTEN(IL-POS('.',OPER)); % C(*$S+*)  UNIT BASIC; INTRINSIC CODE 25; "INTERFACE $FUNCTION VAL (OPER:STRING):REAL; $  IMPLEMENTATION !FUNCTION VAL; !VAR IL,I:INTEGER; &NUM:SET OF CHAR; & VL:REAL; 'CH:CHAR; !BEGIN #NUM:=['.','-','+','0'..'9']; #VAL:=0; #IF IL = 0 THEN EXITN^Ǥ00ꨐ| "INPUT FILE NAME TO GET SCREEN FROM00먐|0 ;;A <73/+CT$% ')/D;Qá r"(2 ȡǾ#: "INPUT FILE NAME TO STORE SCREEN IN00ꨐ| "INPUT FILE NAME TO GET SCREEN FROM00먐|0 ;;Aצ8COMMAND:M)AKE A GRAPH,S)TORE,R)ECALL,T)EXTMODE,G)RAFMODEצ C)LEAR SCREEN,Q)UITȡǾ#: "INPUT FILE NAME TO STORE SCREEN INBpBB $FUNCTION VAL (OPER:STRING):REAL; $  IMPLEMENTATION E DEISKISKԍ֍brrb^brAP1`b66^``Pb6rץ/צ *SYSTEM.APPLE--+ ,(,-+V~ԍ֍br r b^brAPP`b66^``Pb6r BMOVEHEAP { start heap at $D00 } "BLOCK_BUFFER[296]:=PAGE_OF_MEMORY; { heap not moved until re-boot } "BLOCKS_TRANSFERRED:=BLOCKWRITE(SYS_FILE, BLOCK_BUFFER, 1, BLOCK_NUMBER);  END.  : FILE; $BLOCK_NUMBER, $PAGE_OF_MEMORY, $BLOCKS_TRANSFERRED : INTEGER; $  BEGIN "RESET(SYS_FILE, '*SYSTEM.APPLE'); "BLOCK_NUMBER:=18; "BLOCKS_TRANSFERRED:=BLOCKREAD(SYS_FILE, BLOCK_BUFFER, 1, BLOCK_NUMBER); "PAGE_OF_MEMORY:=13; e }  { relocated when the disk is re-booted. The value }  { of PAGE_OF_MEMORY determines the starting page of }  { the heap. }   VAR BLOCK_BUFFER : PACKED ARRAY[0..511] OF 0..255; $SYS_FILE  {==================================}  { LISTING #3: MOVE_HEAP }  {==================================}   PROGRAM MOVE_HEAP;   { This program will only work properly for Pascal 1.1 }  { It modifies the boot disk so that the heap will bN^CAP1TEXT FN(VAL).CODEz6z|z6P1b6*,, FN(VAL).CODEAPDISKFN(VAL).TEXT FN(VAL).CODECODE[*]C2:SYSTEM.SWAPDISKڪP/h.á-.B-BȡE-AA/.-"A.A-˄A+˄?? A0--צ.š??..$-AA-á ??~ 66^``Pb6rAP1TEXT FN(VAL).CODEz6z|z6P1b6*,, FN(VAL).CODEAPDISKFN(VAL).TEXT FN(VAL).CODECODE[*]C2:SYSTEM.SWAPDISKAPPLE1T MOVEHEAP.CODEz6z|z6PPb6*,, MOVEHEAP.CODEPDISK) ̅(צMOVEHEAP.TEXT - %̅,ړצLis MOVEHEAP.CODEODE[*]C2:SYSTEM.SWAPDISK.N^蠨N^蠨LN CMP #CTLB ;CTRL-B  BNE NOCTLB (LDA #0DC ;BACKSLASH  NOCTLB AND #0FF (RTS  CONSPECIAL JSR HEAP ;CONNECT SPECIAL  (.END (LDA #05F ;EXTEND PSEUDO-UC (STA 0D84C ;TO INCLUDE '[\]^' (STA 0DB95 ( (LDA 0C088 ;WRITE-PROTECT RAM 8;AND SELECT BANK 1  RTS  SPECIAL LDA KEYBD (CMP #CTLN ;CTRL-N (BNE NOCTLN (LDA #0DF ;UNDERSCORE  NOCT (.PROC SPECIALCHAR  ;LOAD SPECIAL ROUTINE UNDERNEATH HEAP (LOAD SPECIAL,HEAP,012 (  ;CONNECT TO SYSTEM AND EXTEND PSEUDO-UC  (STA 0C083 ;WRITE-ENABLE RAM 8;AND SELECT BANK 2 8  LOAD CONSPECIAL,KEYCK,03 ( 8E ;UNDERSCORE KEY  CTLB .EQU 082 ;BACKSLASH KEY  ;LOAD DATA OR ROUTINE ( <= 256 BYTES)  .MACRO LOAD ;FORMAT (LDY #00 ;LOAD SOURCE,DEST,LEN  $1 LDA %1,Y  STA %2,Y (INY (CPY #%3 (BNE $1 (.ENDMAP PROGRAM SHOULD BE USED  ; FIRST TO MAKE SPACE FOR THE SPECIAL ROUTINES.  KEYBD .EQU 0C000 ;KEYBOARD INPUT PORT  HEAP .EQU 0C00 ;HEAP NORMALLY STARTS HERE  KEYCK .EQU 0D78F ;KEYBOARD CHECK 8;D78F: LDA 0C000  CTLN .EQU 0;----------------------------------  ; LISTING #1: SPECIALCHAR ROUTINE  ;  ; WRITTEN BY RON DE GROAT 8-APR-81  ;----------------------------------   ; THIS PROCEDURE MAKES _\{|}~ AVAILABLE  ; TO THE APPLE KEYBOARD UNDER PASCAL 1.1.  ; THE MOVE HE PROGRAM GREETING;   { This program should be linked to }  { SPECIALCHAR and stored in a file }  { named SYSTEM.STARTUP. }   PROCEDURE SPECIALCHAR; EXTERNAL;   BEGIN "SPECIALCHAR; "GOTOXY (6,10); "WRITE ('Welcome to Pascal 1.1 witHTYPE: MTYPES; QFILLER: 0..1; QMAJORREVISION: REVISIONS; OEND; 4INTSEGSET: SEGSET; 4FILLER2: ARRAY [0..109] OF INTEGER; 2END { SEGDIREC };   VAR "SEGDIC: SEGDICREC; "F: FILE; "  FUNCTION YESNO: BOOLEAN; "VAR CH: CHAR;  BEGIN "REPEAT $WRIT = (NONAPPLE, ONEZERO, ONEONE, FUTURE1, FUTURE2, FUTURE3, 3FUTURE4, FUTURE5); "SEGSET = SET OF SEGRANGE; "SEGDICREC = RECORD 4FILLER1: PACKED ARRAY [0..255] OF CHAR; 4SEGINFO: ARRAY [SEDICRANGE] OF OPACKED RECORD QSEGNO: 0..255; QMAC(*$I-*)  PROGRAM FORTFIX;  CONST "MAXSEG = 31; "MAXSLOT = 15;  TYPE "SEGRANGE = 0..MAXSEG; "SEDICRANGE = 0..MAXSLOT; "MTYPES = (UNDEF, PCODEMOST, PCODELAST, PDP11, M8080, 3Z80, GA440, M6502, M6800, TI9900); "REVISIONS N^CAPPLE1TLC.STARTUP.CODE6z|z6PPbU6*,,LC.STARTUP.CODEISK LC.STARTUP.TEXTLC.STARTUP.CODEE[*]C2:SYSTEM.SWAPDISK צWelcome to Pascal 1.1 with  צSpecial char keyboard inputd) ;_L؍ۭ`Ɏɂ)` =/JRAPP`b66^``Pb6rGGREETING h '); "GOTOXY (6,12); "WRITE ('Special char keyboard input');  END. E (' Y(es or N(o:'); $READ (CH); $WRITELN; "UNTIL CH IN ['Y','y','N','n']; "YESNO := CH IN ['Y','y'];  END;   PROCEDURE ERROR (MESSAGE: STRING);  BEGIN "WRITELN; "WRITELN ('===>ERROR ', MESSAGE); "WRITE (' RETURN to abort:'); "READLN; "EXIT (FORTFIX);  END;   PROCEDURE INIT; "VAR FCNAME: STRING;  BEGIN "WRITE ('Name of FORTRAN code file: '); "READLN (FCNAME); "RESET (F,FCNAME); "IF IORESULT <> 0 THEN $ERROR ('Opening code file'); "IF BLOCKREAD (F,SEGDIC,1,0) <> 1 THEN $Eצ FORTFIX successfully terminated.pץ/P &,ICS 20 & 21 APPLESTUFF 22צ CHAINSTUFF 28 TRANSCEND 29צ LONG INTEGERS 30 PASCALIO 31سdINTRINSIC UNIT #: "ˡReading intrinsic unit #سؗs ˡצWriting segment dictionary%Enter unit numbers in the range 7..31צEnter "99" when finished. TURTLEGRAPHICS 20 & 21 APPLESTUFF 22צ CHAINSTUFF 28 TRANSCEND 29צ LON"ˡצOpening code fileˡ"צReading the segment directoryRȡ2Ä Ä  : H#Does this FORTRAN code file use anyצintrinsic units  Y(es or N(o:ڳ@@ڳV^تPצ ===>ERROR  RETURN to abort:R^Name of FORTRAN code file: PBvFORTFIX HEN $ERROR ('Writing segment dictionary'); "WRITELN; "WRITELN ('FORTFIX successfully terminated.');  END;   BEGIN {main program} "INIT; "FIXMAJVER; "FIXINTRINSEGSET; "FINISHUP;  END. {main}  NSIC UNIT #:'); .READ (IUNIT); .IF IORESULT <> 0 THEN 0ERROR ('Reading intrinsic unit #'); .IF IUNIT IN [7..31] THEN 0INTSEGSET := INTSEGSET + [IUNIT]; ,END; (END; $END;  END;   PROCEDURE FINISHUP;  BEGIN "IF BLOCKWRITE (F,SEGDIC,1,0) <> 1 T*WRITELN (' APPLESTUFF 22'); *WRITELN (' CHAINSTUFF 28'); *WRITELN (' TRANSCEND 29'); *WRITELN (' LONG INTEGERS 30'); *WRITELN (' PASCALIO 31'); *WRITELN; *INTSEGSET := []; *WHILE IUNIT IN [7..31] DO ,BEGIN .WRITE ('INTRI &WRITE ('intrinsic units '); &IF YESNO THEN { Fill in INTSEGSET } (BEGIN *IUNIT:=7; *WRITELN ('Enter unit numbers in the range 7..31'); *WRITELN ('Enter "99" when finished.'); *WRITELN; *WRITELN (' TURTLEGRAPHICS 20 & 21'); :AND (MAJORREVISION = NONAPPLE) THEN ,BEGIN .MACHTYPE := PCODELAST; .MAJORREVISION := ONEZERO; ,END; $END;  END;   PROCEDURE FIXINTRINSEGSET; "VAR IUNIT: INTEGER;  BEGIN "WITH SEGDIC DO $BEGIN &WRITELN ('Does this FORTRAN code file use any');RROR ('Reading the segment directory');  END;   PROCEDURE FIXMAJVER; "VAR SLOT: INTEGER;  BEGIN "WITH SEGDIC DO $BEGIN &FOR SLOT := 0 TO MAXSLOT DO { Fix major-version problems } (WITH SEGINFO [SLOT] DO *IF (SEGNO <> 0) AND (MACHTYPE = UNDEF) G INTEGERS 30 PASCALIO 31سdINTRINSIC UNIT #: "ˡReading intrinsic unit #سؗs ˡצWriting segment dictionaryN^Ǥ[CR,BS] (ELSE GETSET:=OKSET+[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*) !; %FIRSTCHAR :BOOLEAN; %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:=$ELSE IF CH IN [' '..CHR(125)] +THEN WRITE(CH); "UNTIL GOOD; "GETCHAR:=CH; !END; (*GETCHAR*) ! !  PROCEDURE GETSTRING (VAR S:STRING;  OKSET:SETOFCHAR; MAXLEN:INTEGER); $ !VAR S1 :STRING[1]; %STEMP :STRING; %LEN :INTEGERSETOFCHAR):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) DISASSEM which automatically *) !(* adjusts IC to point to the next *) !(* instruction to be disassembled. *) ! !  PROCEDURE ABORT;  !BEGIN "WRITE(HOME); "ESCOK:=FALSE; "EXIT(DOCHOICE); !END; (*ABORT*) ! !  FUNCTION GETCHAR (OKSET:TCHARBYTE(ADDR:INTEGER); EXTERNAL;  PROCEDURE BANK1POKE(ADDR,VAL:INTEGER); EXTERNAL;  PROCEDURE BANK2POKE(ADDR,VAL:INTEGER); EXTERNAL;   PROCEDURE DOCHOICE; FORWARD;   (* WARNING: The variable IC is public *) !(* to PROCEDURE MONITOR; EXTERNAL;  PROCEDURE SWITCHBANK; EXTERNAL;  PROCEDURE PRINTXADDR(ADDR:INTEGER); EXTERNAL;  PROCEDURE PRINTHEXBYTE(ADDR:INTEGER); EXTERNAL;  PROCEDURE PRIN :MAGIC; $HEXADDR,HEXBYTE :STRING; $PSW :STRING[3]; $  PROCEDURE INITDISASSEM; EXTERNAL;  PROCEDURE DISASSEM; (* USES IC *) EXTERNAL; TEGER;  LINECOUNT,J,I,TEMP :INTEGER; $IC (*INST COUNTER*) :INTEGER; $HOME,EOL,BELL,CH :CHAR; $ESC,BS,CR :CHAR; $DESET,HEXSET,PMUSET :SETOFCHAR; $GOOD,ESCOK :BOOLEAN; $CSW S='0123456789ABCDEF'; &PRINTADDR=-16128; (* $C100 *) &COUT1=-528; (* $FDF0 *) &  TYPE MAGIC=RECORD CASE BOOLEAN OF ,TRUE: (ADDR: INTEGER); ,FALSE:(VECTOR:^INTEGER); +END; + %SETOFCHAR=SET OF CHAR;   VAR ENDADDR,ADDR,VAL,BANK :IN(*************************************)  (* LISTING #1: PASCAL MEMORY UTILITY *)  (* *)  (* WRITTEN BY RON DEGROAT 15-APR-81 *)  (*************************************)    (*$S+*)  PROGRAM PMU;   CONST XDIGIT !  PROCEDURE PROMPTAT (L:INTEGER;S:STRING); ! !BEGIN "GOTOXY(0,L); "WRITE(S,EOL); !END; ! !  FUNCTION DEC (HEXSTR:STRING):INTEGER; ! !VAR DIGIT,NUM,POWER, %START,STRPTR :INTEGER; %S1 :STRING[1]; % !BEGIN "POWER:=1; NUM:=0; S1:='0'; "START:=LENGTH(HEXSTR); "FOR STRPTR:=START DOWNTO 1 DO #BEGIN $S1[1]:=HEXSTR[STRPTR]; $DIGIT:=POS(S1,XDIGITS)-1; $NUM:=NUM+(DIGIT*POWER); $POWER:=POWER*16; #END; "DEC:=NUM; !END; (*DEC*) ! !  PROCEDURE GETADDR (STRCHR(12); (*CTRL-L*) #BELL:=CHR(7); (*CTRL-G*) #EOL:=CHR(29); (*CTRL-]*) #ESC:=CHR(27); (*CTRL-[*) #BS:=CHR(8); (*CTRL-H*) #CR:=CHR(13); (*CTRL-M*) # #ESCOK:=FALSE; #BANK:=1; #PSW:='OFF'; (*PRINT#WRITE(HOME); #ESCOK:=TRUE; #CASE CH OF $'D','d':DISASM; $'E','e':EXAMINE; $'C','c':CHANGE; $'B','b':BANKCHANGE; $'P','p':PRINT; $'M','m':MONITOR; #END; (*CASE*) #ESCOK:=FALSE; "END; (*DOCHOICE*) " " !PROCEDURE INITIALIZE; ! "BEGIN #HOME:=%EXIT(PRINT); $END; "(*$I+*) " #IF PSW='OFF' THEN $BEGIN %CSW.VECTOR^:=PRINTADDR; %PSW:='ON'; %LINECOUNT:=16; $END #ELSE $BEGIN %CSW.VECTOR^:=COUT1; %PSW:='OFF'; %LINECOUNT:=8; $END; "END; (*PRINT*) " " !PROCEDURE DOCHOICE; " "BEGIN  %'R','r':RANGE; %'B','b':BANKCHANGE; $END; (*CASE*) #UNTIL CH IN ['Q','q']; "END; (*DISASM*) " " !PROCEDURE PRINT; ! "BEGIN " "(*$I-*) #UNITCLEAR(6); #IF IORESULT<>0 THEN $BEGIN %PROMPTAT(3,'SORRY, NO PRINTER'); %WRITE(' ON-LINE'); ASSEM (* IC *) "END; (*RANGE*) " " !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); $WRITE(HOME); $CASE CH OF %'L','l':LIST; %'N','n':NEXT;(*IC (INSTR COUNTER)*) #NEXT; (*PUBLIC TO DISASSEM*) "END; " " !PROCEDURE RANGE; ! "BEGIN #WRITE(HOME); #PROMPTAT(0,'DISASM: RANGE'); #GETADDR('STARTADDR ==> '); #IC:=ADDR; #GETADDR('ENDADDR ==> '); #WRITE(HOME); #WHILE IC<=ADDR DO DIS$END; #UNTIL CH='Q'; "END; (*EXAMINE*) " " !PROCEDURE NEXT; ! "BEGIN #FOR I:=1 TO 20 DO DISASSEM (* IC *); "END; (*NEXT*) " " !PROCEDURE LIST; ! "BEGIN #PROMPTAT(0,'DISASM: LIST'); #GETADDR('STARTADDR ==> '); #WRITE(HOME); #IC:=ADDR; E EXAMINE; ! "VAR CH:CHAR; " "BEGIN #REPEAT # PROMPTAT(0,'EXAMINE: L)IST N)EXT '); $WRITE('R)ANGE B)ANK[',BANK,'] Q)UIT'); $CH:=GETCHAR(DESET); $WRITE(HOME); $CASE CH OF %'L','l':XLIST; %'N','n':XNEXT; %'R','r':XRANGE; %'B','b':BANKCHANGE; > '); #TEMP:=ADDR; #GETADDR('ENDADDR ==> '); #WRITE(HOME); #ENDADDR:=ADDR; #ADDR:=TEMP; #WHILE ADDR<=ENDADDR DO LINEOFBYTE(ADDR); "END; (*XRANGE*) " " !PROCEDURE BANKCHANGE; ! "BEGIN #BANK:=(BANK MOD 2)+1; #SWITCHBANK; "END; " " !PROCEDURT; ! "BEGIN #FOR I:=1 TO 20 DO LINEOFBYTE(ADDR); "END; " " !PROCEDURE XLIST; " "BEGIN #PROMPTAT(0,'EXAMINE: LIST'); #GETADDR('STARTADDR ==> '); #WRITE(HOME); #XNEXT; "END; (*XLIST*) " " !PROCEDURE XRANGE; " "BEGIN #GETADDR('STARTADDR ==!PROCEDURE LINEOFBYTE (VAR ADDR:INTEGER); " "BEGIN #PRINTXADDR(ADDR); #FOR J:=ADDR TO ADDR+LINECOUNT-1 DO %PRINTHEXBYTE(J); #FOR J:=ADDR TO ADDR+LINECOUNT-1 DO %PRINTCHARBYTE(J); #ADDR:=ADDR+LINECOUNT; (*ADJUST ADDR*) "END; " " !PROCEDURE XNEX(HEXBYTE),1); #IF LENGTH(HEXBYTE) <> 0 THEN %BEGIN & VAL:=DEC(HEXBYTE); 'IF BANK=1 THEN BANK1POKE(ADDR,VAL) 1ELSE BANK2POKE(ADDR,VAL); %END; #PRINTHEXBYTE(ADDR); #ADDR:=ADDR+1; "UNTIL FALSE; !END; (*CHANGE*) ! ! '); "WRITE(HOME); "REPEAT #PROMPTAT(1,'CHANGE: ( '); #WRITE('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:STRING);  !BEGIN "WRITELN; WRITELN; "WRITE(STR); "GETSTRING(HEXADDR,HEXSET,4); "ADDR:=DEC(HEXADDR); !END; (*GETADDR*) ! !  PROCEDURE CHANGE;  !BEGIN "PROMPTAT(0,'CHANGE: ( '); "WRITE('TO QUIT, TO SKIP'); "GETADDR('STARTADDR ==> ER SWITCH*) #LINECOUNT:=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','C','c','P','p','Q','q']; , #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,'] '); #WRITE('M)ONITOR B)ANK[',BANK,'] Q)UIT'); #CH:=GETCHAR(PMUSET); ;CTRL-Y JUMP (ROMSELECT (JMP MON  RET PLA ;REMOVE CTRL-Y ADDR (PLA (STA 0C088 ;SWITCH ON RAM BANK1 (RTS  USER JMP RET   (.PROC PRINTXADDR,1 ( (POP RETURN (PLA ;GET ADDR (TAX (PLA (TAY (ROMSELECT (J ;POKE VAL INTO ADDR (STA 0C088 ;WRITE-PROTECT RAM 8;SELECT SECOND BANK (PUSH RETURN (RTS ( ( (.PROC BANK2POKE,2 ( (.REF POKE ( (STA 0C081 ;WRITE-ENABLE 8;SECOND 4K BANK (JMP POKE ( ( (.PROC MONITOR ( (LOAD USER,03FB,03 ( (.MACRO ROMSELECT (STA 0C08A (.ENDM ( ( (.MACRO RAMSELECT (JSR BANK (.ENDM ( ( (.PROC BANK1POKE,2 ( (.DEF POKE ( (STA 0C089 ;WRITE-ENABLE 8;FIRST 4K BANK  POKE POP RETURN (POP VAL (POP ADDR (LDA VAL (LDY #00 (STA (ADDR),Y (INY (CPY #%3 (BNE $1 (.ENDM (   ;POP ADDR FROM STACK  (.MACRO POP ;FORMAT: POP ADDR (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 ( 0000 ;PASCAL RET ADDR  ADDR .EQU 00002 ;PASSED PARM  VAL .EQU 00004 ;PASSED PARM   ;LOAD DATA OR ROUTINE (NO MORE THAN 256 BYTES)  (.MACRO LOAD ;FORMAT: (LDY #00 ;LOAD SOURCE,DEST,LEN  $1 LDA %1,Y (STA %2,YKBD .EQU 0FE89   PRBYTE .EQU 0FDDA ;CHAR OUTPUT  COUT .EQU 0FDED ;SUBROUTINES  PRYX2 .EQU 0FD96  PRBLNK .EQU 0F948   PCADJ .EQU 0F953  PC .EQU 0003A ;PGM COUNTER  MON .EQU 0FF65 ;MONITOR   RETURN .EQU 0;------------------------------------  ;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  SETN^Ǥ #DOCHOICE; "UNTIL CH IN ['Q','q']; ! !END. " SR PRYX2 ;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 (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 ==> ȡ LEXAMINE: L)IST N)EXT צ R)ANGE B)ANK[ ] Q)UIT3 عvrnjBrb  ,, 0$&(*,.0246Fá   ȡ  ȡ  񂚭4 Lȡ   EXAMINE: LISTSTARTADDR ==> :צSTARTADDR ==> צ ENDتPo#oR:CHANGE: ( צTO QUIT, TO SKIPצSTARTADDR ==> צCHANGE: ( TO QUIT, TO SKIPO  F#OFFFPQPP2á( =áP$ تPR(ڪP/020..-3-3ġA2-20123456789ABCDEF101/0//--0O` tC   éC   } \$ d  תP==>=?> @$?@@@ PPPG PMU OMSELECT ;SWITCH ON ROM (TAY (RTS (  DIS2 RAMSELECT (LDA (PC),Y (ROMSELECT (JMP PRBYTE (  DIS3 CMP #0E8 (RAMSELECT (LDA (PC),Y (ROMSELECT (RTS ( ( (.END  ( ( ( SETVID (JSR SETKBD (RAMSELECT ;SWITCH ON LANG CARD (RTS (  CHANGE1 JSR DIS1   CHANGE2 JSR INSDS1 (PHA (JSR DIS2 (NOP (NOP (  CHANGE3 JSR DIS3 (NOP (  DIS1 RAMSELECT ;SWITCH ON LANG CARD (LDA (PC,X) ;GET OPCODE BYTE (R(  INSTDSP .EQU INSDS1+04E  PATCH1 .EQU INSDS1+00A  PATCH2 .EQU INSTDSP  PATCH3 .EQU INSDS1+0B0   ;MAKE NECESSARY PATCHES & SETUP VIDEO  (LOAD CHANGE1,PATCH1,03 (LOAD CHANGE2,PATCH2,09 (LOAD CHANGE3,PATCH3,04 (JSR SETNORM (JSR INIT (JSR ( (.REF BANK ( (JMP BEGIN ;SKIP COPY AREA (  ;COPY MAIN PART OF 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 COPY C+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 INSTDSP BANK+1 ;CHANGE 0C088 (EOR #08 ;TO 0C080 AND (STA BANK+1 ;VICE VERSA (RTS  BANK STA 0C088 (RTS ( ( (.PROC DISASSEM ( (.PUBLIC IC (.REF INSTDSP,BANK ( (LDA IC ;TRANSFER IC (STA PC ;TO PC (LDA IC+1 (STA PADDR),Y ;GET CHAR BYTE (ORA #80 ;SET HI BIT (CMP #0A0 ;PRINT CONTROL (BCS NORMAL ;CHARS AS '.' (LDA #0AE ;'.'  NORMAL ROMSELECT (JSR COUT (STA 0C088 (PUSH RETURN (RTS ( ( (.PROC SWITCHBANK ( (.DEF BANK ( (LDA 8:<>@LDFHJLNPRTlXl\^`pQá ȡ  DISASM: LISTצSTARTADDR ==>  < DISASM: RANGESTARTADDR ==>  ENDADDR ==> ȡ bDISASM: L)IST N)EXT  R)ANGE B)ANK[ צ] Q)UIT3 عuqmiBrb  ++ /$&(*,.02468:<>@KDFHJLNPRTkXk\^`oسian coords} $Vx,Vy, {Velocity components} $R,R_CUBED, {Radial dist to center}  SIGN, {For att. or rep. forces} $dT:REAL; {Time step} $NUM_STEPS, $XPLOT,YPLOT, {Plotter coords} $I:INTEGER; {Counter} $CR,BS :CHAR; {,  (* WRITTEN BY RON DEGROAT MAY 1981 *)  (* *)  (**************************************)   PROGRAM EARTH_ORBIT;   USES TURTLEGRAPHICS, TRANSCEND;   TYPE SETOFCHAR = SET OF CHAR;   VAR X,Y, {Cartes(**************************************)  (* LISTING #1: EARTH_ORBIT *)  (* *)  (* THIS PROGRAM PLOTS EARTH ORBITS *)  (* USING THE HALF-STEP METHOD *)  (* *) N^Ǥ9 H C N :` :L :`[skjbaYXBA?< P>6+T\*":D 8 x d ^ F~:&) ,Q 5 / ` H`(hhhh  HH`2hhhh  ɠ HH`#6 I ``  :!; ' S:; !`)&4L] צM)ONITOR B)ANK[ ] Q)UIT .hhhhhhHH`.Lu Lehh`L(hhhh HJLNPRTVbZ\lC    COFFת 6E3PP< < #~PMU: D)ISASM E)XAMINE C)HANGE P)RINT[צ&"ˡ-צSORRY, NO PRINTER ON-LINEOFFׯE?ONת EOFFת vCzvrnjfBp^$" ", "$&(*,.02468:<>@TZdb} $  FUNCTION GET_CHAR(OKSET:SETOFCHAR):CHAR;   VAR CH :CHAR; #GOOD :BOOLEAN; #  BEGIN "REPEAT $READ(KEYBOARD,CH); $IF EOLN(KEYBOARD) THEN CH:=CR; $GOOD:=CH IN OKSET; $IF NOT GOOD THEN WRITE(CHR(7)) &ELSE IF CH IN [' '..CHR(125)] -THEN WRITE(CH); "UNTIL GOOD; "GET_CHAR:=CH;  END; {GET_CHAR}    FUNCTION FP_NUM(FP_STR:STRING):REAL;   VAR POWER,SIGN,LEN :INTEGER; $NUM :REAL; $  BEGIN "IF FP_STR[1]='-' THEN $BEGIN &SIGN:=-1; &DELETE(FP_STR,1,1);'c'] THEN PLOT_AXES; "DONE:=(CH IN ['Q','q']);  END; {DONE}    BEGIN {MAIN PROGRAM}  "CR:=CHR(13); {ctrl-m} "BS:=CHR(8); {ctrl-h} " "PLOT_AXES; " "REPEAT " $GET_INITIAL_VALUES; $ $PLOT_ORBIT; " "UNTIL DONE; "  END.  AN;   VAR CH:CHAR;   BEGIN "READ(KEYBOARD,CH); {Wait for keypress} "TEXTMODE; {to leave graphics} " "WRITE('C)LEAR SCREEN P)LOT AGAIN Q)UIT'); "CH:=GETCHAR(['C','c','P','p','Q','q']); "WRITELN(BS,' '); "WRITELN; "IF CH IN ['C',$YPLOT:=ROUND(Y+95); $MOVETO(XPLOT,YPLOT); $ $R:=SQRT(SQR(X)+SQR(Y)); $R_CUBED:=R*R*R; $ "{Calculate new velocity} $Vx:=Vx-SIGN*(X/R_CUBED)*dT; $Vy:=Vy-SIGN*(Y/R_CUBED)*dT; " "END; {PLOT LOOP} "  END; {PLOT_ORBIT}    FUNCTION DONE:BOOLEND; {GET_INITIAL_VALUES}    PROCEDURE PLOT_ORBIT;   BEGIN " "GRAFMODE; {Switch on the graphics} " "FOR I:=1 TO NUM_STEPS DO " "BEGIN " "{Calculate next point} $X:=X+Vx*dT; $Y:=Y+Vy*dT; $ "{Plot next point} $XPLOT:=ROUND(X+140);  "Vx:=Vx-SIGN*(X/R_CUBED)*dT/2; "Vy:=Vy-SIGN*(Y/R_CUBED)*dT/2; "  {Calculate and plot initial (X,Y)}  {Center of earth = (140,95)}  "XPLOT:=ROUND(X+140); "YPLOT:=ROUND(Y+95); "PENCOLOR(NONE); MOVETO(XPLOT,YPLOT); "PENCOLOR(WHITE); "  E; "dT:=GET_FP_NUM('TIME STEP: ',3,0); "WRITE('A)TT OR R)FP FORCE CENTER? '); "CH:=GETCHAR(['A','a','R','r']); "WRITELN; "IF CH='R' THEN SIGN:=-10000 $ELSE SIGN:=10000; " "R:=SQRT(SQR(X)+SQR(Y)); "R_CUBED:=R*R*R; "  {Calculate initial half-step} "X :=GET_FP_NUM('INITIAL X COORD: ',150,-150); "Y :=GET_FP_NUM('INITIAL Y COORD: ',150,-150); "Vx:=GET_FP_NUM('INITIAL X VELOCITY: ',150,-150); "Vy:=GET_FP_NUM('INITIAL Y VELOCITY: ',150,-150); "NUM_STEPS:=TRUNC(GET_FP_NUM('NUMBER OF STEPS: ',9999,0))ONE); MOVETO(209,95); "PENCOLOR(WHITE); MOVETO(70,95); "PENCOLOR(NONE); MOVETO(140,161); "PENCOLOR(WHITE); MOVETO(140,30);  END; {PLOT_AXES}    PROCEDURE GET_INITIAL_VALUES;   VAR CH:CHAR;   BEGIN TE(FP_STR_TEMP,LEN,1); &END; " "UNTIL S1[1]=CR; "WRITELN; " "GET_FP_NUM:=FP_NUM(FP_STR_TEMP); "  END; {GET_FP_NUM}    PROCEDURE PLOT_AXES;   BEGIN "INITTURTLE; {Clear hires screen, but} "TEXTMODE; {don't show graphics yet} "PENCOLOR(N:=FP_NUM(FP_STR_TEMP); (IF (NUM>MAX) OR (NUM0 THEN $BEGIN &DELETE(FP_STR,POWER,1); &POWER:=LENGTH(FP_STR)-POWER+1; $END; $ $NUM:=0; $LEN:=LENGTH(FP_STR); $FOR I:=1 TO LEN DO &NUM:=10*NUM+(ORD(FP_STR[I])-ORD('0')); $FP_NUM:=SIGEARTHORB PROCEDURE 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^unj_       צC)LEAR SCREEN P)LOT AGAIN Q)UIT ڳڳ#  0$, <B>nj_ ȡ  nj_       צC)LEAR SCREEN P)LOT AGAIN Q)UIT Rá ''      nj_ ȡ  צINITIAL X COORD: ǖǖINITIAL Y COORD: ǖǖ צINITIAL X VELOCITY: ǖǖ צINITIAL Y VELOCITY: ǖǖצNUMBER OF STEPS: 'צ TIME STEP: A)TT OR R)FP FORCE CENTER? ƀ5 }ʀGTá=צ.}ʀá1 }ʀTá} _F_njǡnj: T P}צP1}̀ʀ3ʀ21DD@DD@3 4D1244D T4T.1TDz}̀ƀ}PƀTǠƀPƀ}ƀ   } P$XڪP-á ..צ.//ˡ///0--22ȡ0 00.0/$7^ުPDB0 !pasfile :ffile; !primpage, !sparepage :pagebuffer; !pagepntr, !sparepntr :pagerange; !relblock :INTEGER; !filetype :pasfilekinds;  fotoflag :BOOLEAN; (* flag for shifts of size 'binaryoffset' *)  !PROCEDURE abortxfer(ioerror:INTEGER); !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(#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> '); ! 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; ! !FUNCTION searchdir(target:did;VAR index:dirrange):BOOLEAN; !VAR "found:BOOLEAN; !BEGIN "found:=FALSE; "index:=dosdir[0].dnumentries; ! WHILE NOT (found OR (index=0)) DO #BEGIN $found:=target=dosdir[index].name; $index:=index-1; #END; ! IF foun=ioresult; "IF NOT (ioerror=0) THEN writetrksec:=FALSE #ELSE BEGIN $moveleft(sb,block[offset+1],sizeof(sectbuffer)); $(*$I-*) $unitwrite(unitnum,block,sizeof(block)); $(*$I+*) $ioerror:=ioresult; $writetrksec:=ioerror=0;