The Best of Mecomp Multimedia 2

home *** CD-ROM | disk | FTP | other *** search

/ The Best of Mecomp Multimedia 2 / MECOMP-CD-II.iso / amiga / emulation / qlboot-data / sys_ref_bas < prev next >

Wrap

Text File | 1998-02-24 | 20.4 KB | 641 lines

10 TURBO_objfil "ram1_SYS_REF_task" 11 TURBO_taskn "SYS_REF" 12 TURBO_repfil "scr" 13 TURBO_windo 0 14 TURBO_diags 'omit' 15 TURBO_struct "S" 16 TURBO_model "<" 17 TURBO_objdat 10 18 TURBO_optim "R" 19 : 1000 REMark ------------------------------ 1010 REMark SYS_REF_bas - Mark J Swift 1070 REMark ------------------------------ 1080 : 1170 DIM InFile$(100),OutFile$(100),Rplc$(1),P$(256),Src$(5),Dst$(40),Name$(40),Space$(40),temp$(40),nam$(64),pch$(256),a$(100),verstag$(4) 1180 verstag$="1.10" 1190 Buff=ALCHP(256) 1200 Rows=14 1210 DIM D(Rows/2) 1220 OPEN#3;"Con_456x234a28x12" 1230 OPEN#4;"Scr_104x12a362x20" 1240 OPEN#5;"Scr_436x142a38x99" 1250 InFlg%=0 1260 REPeat outer_loop 1262 RETRY_HERE 1264 IF InFlg%<>0 THEN CLOSE#7:DELETE Dst$&"SYS_REF_dat":InFlg%=0 1270 IF COMPILED 1271 WHEN ERRor 1272 PRINT #3\\"Error: " 1273 REPORT #3,ERNUM 1274 INPUT #3;\" Press ENTER to re-start.";Rplc$ 1275 RETRY 1276 END WHEN 1277 END IF 1279 WINDOW#3;456,234,28,12:PAPER#3;0:INK#3;7:CLS#3:BORDER#3;3,2:BORDER#3;2,0:BORDER#3;1,2:WINDOW#3;438,220,36,19:BORDER#5;1,4:INK#5;4:PAPER#5;0 1280 CSIZE#3;2,1:PRINT#3;"SYS_REF v";verstag$:CSIZE#3;0,0 1290 PRINT#3;"CODE-PATCHER by MARK J SWIFT"; 1300 CLS#4:BORDER#4;1,7:INK#4;4:CLS#5 1310 WINDOW#3;438,40,36,59 1320 IF InFlg%=0 THEN 1330 INK#5;4 1340 PRINT#5;" Use SYS_REF to patch tasks & M/C that fail when the system" 1350 PRINT#5;" variables are moved from the usual $28000 location" 1360 PRINT#5;" (i.e. under Minerva or Amiga-QDOS with the 2nd screen enabled)." 1380 PRINT#5;\" If patching CODEGEN_task of the TURBO compiler, patch all references" 1390 PRINT#5;" EXCEPT the two that refer to $28010. These are not part of the CODEGEN" 1400 PRINT#5;" code, but are included in all TURBO compiled programs. If patching" 1410 PRINT#5;" PARSER_task, or any other TURBO program replace ALL references." 1420 PRINT#5;\" Patched versions of TURBO produce code identical to unpatched" 1430 PRINT#5;" versions, i.e. compiled tasks still require patching." 1440 PRINT#5;\" NOTE: SYS_REF makes all TURBO'ed & some QLIB'ed programs 32-bit clean." 1450 INPUT#3;\"Input FILE or VOLUME name >";InFile$ 1460 IF InFile$="" THEN EXIT outer_loop 1470 IF LEN(InFile$)=5 THEN 1480 InFlg%=INT(((InFile$ INSTR "flp1_flp2_flp3_flp4_ram1_ram2_")+4)/5) 1490 ELSE 1500 InFlg%=0 1510 END IF 1520 IF InFlg%=0 THEN 1530 INPUT#3;" Output FILE name >";OutFile$ 1540 IF OutFile$="" THEN EXIT outer_loop 1550 ELSE 1560 INPUT#3;" Output VOLUME name >";OutFile$ 1570 IF OutFile$="" THEN InFlg%=0:EXIT outer_loop 1580 Src$=InFile$:Dst$=OutFile$ 1590 DELETE Dst$&"SYS_REF_dat" 1600 OPEN_NEW#7;Dst$&"SYS_REF_dat" 1610 DIR#7;Src$:CLOSE#7 1620 OPEN_IN#7;Dst$&"SYS_REF_dat" 1630 INPUT#7;Name$,Space$ 1640 END IF 1650 CLS#5 1660 END IF 1670 REPeat main_loop 1680 REPeat in_loop 1690 CLS#4:CLS#3:RPORT CHR$(10) 1700 IF InFlg%<>0 THEN 1710 IF EOF(#7) THEN 1720 EXIT main_loop 1730 ELSE 1740 INPUT#7;InFile$ 1750 OutFile$=Dst$&InFile$ 1760 InFile$=Src$&InFile$ 1770 END IF 1780 END IF 1790 OPEN_IN#6;InFile$ 1800 el=0:fd=0:fl=FLEN(#6):ft=FTYP(#6):IF ft THEN fd=FDAT(#6) 1810 CLOSE#6 1820 RPORT "File: "&InFile$&CHR$(10) 1830 IF fl=0 THEN 1840 RPORT "File empty!"&CHR$(10) 1850 IF InFlg%=0 THEN EXIT main_loop 1860 ELSE 1861 INK#3;4 1862 IF ft=1 AND fd<>0 THEN 1864 RPORT "Executable TASK"&CHR$(10) 1866 ELSE 1870 temp$=FILE_CLASS$(InFile$) 1880 IF temp$<>"" THEN 1890 RPORT "Possible "&temp$&CHR$(10) 1900 END IF 1902 END IF 1904 INK#3;7 1910 IF InFlg%=0 THEN 1920 EXIT in_loop 1930 ELSE 1940 RPORT "Patch":Rplc$=WAITKEY$(3,"ynq") 1950 IF Rplc$=="y" THEN EXIT in_loop 1960 IF Rplc$=="q" THEN EXIT main_loop 1970 END IF 1980 END IF 1990 END REPeat in_loop 2000 CLS#5 2010 base=ALCHP(fl) 2020 IF base>0 THEN 2030 LBYTES (InFile$(1 TO LEN(InFile$))),base 2040 ELSE 2050 PRINT#3;\"Out of memory!" 2060 EXIT outer_loop 2070 END IF 2080 REMark do it 2090 NoRpc%=0 2100 fixSYSV 2110 IF NoRpc% THEN 2120 RPORT "Saving..."&CHR$(10) 2125 s=base 2127 IF el<0 THEN 2128 s=base-el 2129 END IF 2130 IF ft=1 THEN 2140 DELETE OutFile$ 2150 SEXEC OutFile$,s,fl,fd 2160 ELSE 2170 DELETE OutFile$ 2180 SBYTES OutFile$,s,fl 2190 END IF 2200 ELSE 2210 RPORT "No changes."&CHR$(10) 2220 END IF 2230 RECHP(base) 2240 IF (InFlg%=0) OR (NoRpc%=0) THEN 2250 Rplc$=INKEY$(#3,200) 2260 IF InFlg%=0 THEN EXIT main_loop 2270 END IF 2280 END REPeat main_loop 2310 END REPeat outer_loop 2320 RECHP(Buff) 2330 CLOSE#3 2340 CLOSE#4 2350 CLOSE#5 2360 IF InFlg%<>0 THEN CLOSE#7:DELETE OutFile$&"SYS_REF_dat":InFlg%=0 2370 STOP 2380 : 2390 DEFine PROCedure fixSYSV 2400 LOCal a,p,i,N,pk,pflg% 2410 CLS#4 2420 tskFlg%=((PEEK_W(base+6)=HEX("4AFB")) AND (ft<>0)) 2430 IF tskFlg% THEN 2440 nam$="" 2450 pk=PEEK_W(base+8) 2460 FOR i=0 TO pk-1 2470 nam$=nam$&CHR$(PEEK(base+10+i)) 2480 END FOR i 2490 p=base+4+(6+2*INT((LEN(nam$)+1)/2)) 2500 ELSE 2510 p=base+4 2520 END IF 2526 pflg%=0:pch$="":ol=0:versold$=verstag$ 2530 IF PEEK_L(p)=HEX("50544348") THEN 2531 versold$=LONGINT$(PEEK_L(p+4)) 2532 IF STRINGL(versold$)<STRINGL(verstag$) THEN 2533 RPORT "...patched by an outdated version of SYS_REF ":p=p+8 2534 IF versold$>="1.08" THEN 2535 ol=PEEK_L(p):NoRpc%=PEEK_W(p+4):p=p+6 2536 ELSE 2537 NoRpc%=PEEK_W(p):p=p+2 2542 IF tskFlg% THEN 2543 ol=78+4*NoRpc%+2*INT((LEN(nam$)+1)/2) 2544 ELSE 2545 ol=60+LEN(pch$) 2546 END IF 2547 IF versold$=="1.07" THEN 2549 ol=66+40+ol 2552 END IF 2553 END IF 2554 FOR N=1 TO NoRpc% 2555 pch$=pch$&LONGINT$(PEEK_L(p)):p=p+4 2556 END FOR N 2600 ELSE 2610 pflg%=1 2620 RPORT "...already patched by a current version of SYS_REF " 2630 END IF 2640 RPORT "(v"&versold$&")"&CHR$(10) 2650 ELSE 2660 p=0 2670 REPeat find_loop 2680 IF p>fl THEN EXIT find_loop 2690 FOR N=1 TO 256 2700 pk=PEEK_L(base+p) 2710 IF (pk>=HEX("28000")) AND (pk<HEX("28200")) THEN 2720 DISOUT 2730 IF NOT(Rplc$=="a") THEN 2740 RPORT "REPLACE":Rplc$=WAITKEY$(3,"ynaq") 2750 IF Rplc$=="q" THEN 2760 pch$="":EXIT find_loop 2770 END IF 2780 END IF 2790 IF (Rplc$=="y") OR (Rplc$=="a") THEN 2800 pch$=pch$&LONGINT$(p) 2810 NoRpc%=NoRpc%+1 2820 END IF 2830 END IF 2840 p=p+2 2850 IF p>=fl THEN EXIT N 2860 END FOR N 2870 IF p>fl THEN 2880 BLOCK#4;100,10,0,0,4 2890 ELSE 2900 BLOCK#4;INT((p/fl)*100),10,0,0,4 2910 END IF 2920 END REPeat find_loop 2925 END IF 2930 IF pch$<>"" THEN 2940 IF tskFlg% THEN 2950 xl=56+20+4+78+LEN(pch$)+2*INT((LEN(nam$)+1)/2) 2960 ELSE 2970 xl=56+20+4+60+LEN(pch$) 2980 END IF 2982 el=xl-ol 2983 p=0 2984 IF ol<>0 THEN 2985 RPORT "removing old patches - $"&HEX$(ol,32)&" bytes"&CHR$(10) 2987 END IF 2988 IF xl<>0 THEN 2989 RPORT "Extending file by $"&HEX$(xl,32)&" bytes"&CHR$(10) 2990 END IF 2995 IF el<>0 THEN 2998 IF el>0 THEN 2999 RECHP(base):fl=fl+el:base=ALCHP(fl) 3010 LBYTES InFile$,base+el 3012 ELSE 3013 p=-el 3014 fl=fl+el 3015 END IF 3020 END IF 3030 REMark start: 3040 po "6000":POKE_W base+p,2+tskFlg%*(2+2+2+2*INT((LEN(nam$)+1)/2))+8+2+LEN(pch$)+4+28*2:p=p+2:REMark bra skip 3050 IF tskFlg% THEN 3060 po "0000" 3070 po "4AFB":REMark dc.w $4afb 3080 REMark jobname: 3090 POKE_W base+p,LEN(nam$):p=p+2 3100 FOR i=1 TO LEN(nam$):POKE base+p+i-1,CODE(nam$(i)):NEXT i:p=p+2*INT((LEN(nam$)+1)/2) 3110 END IF 3120 po "5054":po "4348":POKE_L base+p,STRINGL(verstag$):p=p+4:REMark dc.b 'PTCHx.xx' 3125 POKE_L base+p,xl:p=p+4 3130 REMark patch_tbl: 3140 POKE_W base+p,LEN(pch$)/4:p=p+2 3150 FOR i=1 TO LEN(pch$)-3 STEP 4:POKE_L base+p,STRINGL(pch$(i TO i+3)):p=p+4:NEXT i 3151 REMark setcach: 3152 RESTORE 3445 3153 FOR i=1 TO 28 3154 READ temp$:po temp$ 3155 END FOR i 3160 REMark skip: 3162 po "4E40":REMark trap#0 - supervisor mode 3164 po "007C":po "0700":REMark ori #$0700,sr - no ints 3170 po "48E7":po "E3F0": REMark movem.l d0-d2/d6/d7/a0-a3,-(a7) 3180 po "7000":REMark moveq #0,d0 3190 po "4E41":REMark trap #1 3192 po "7000":REMark moveq #0,d0 3194 po "61B6":REMark bsr.s setcach 3196 po "2E00":REMark move.l d0,d7 3200 po "45FA":POKE_W base+p,44+12*tskFlg%:p=p+2:REMark lea patch_end(pc),a2 3210 po "43FA":POKE_W base+p,HEX("FFF0")-68-LEN(pch$):p=p+2:REMark lea patch_tbl(pc),a1 3220 po "3219":REMark move.w (a1)+,d1 3230 po "6012":REMark bra.s svdbra 3240 REMark svloop: 3250 po "2419":REMark move.l (a1)+,d2 3260 po "2032":po "2800":REMark move.l (a2,d2),d0 3270 po "0280":po "0000":po "7FFF":REMark andi.l #$7FFF,d0 3280 po "D088":REMark add.l a0,d0 3290 po "2580":po "2800":REMark move.l d0,(a2,d2) 3300 REMark svdbra: 3310 po "51C9":po "FFEC":REMark dbra d1,svloop 3312 po "2007":REMark move.l d7,d0 3314 po "618E":REMark bsr.s setcach 3320 IF tskFlg% THEN 3330 po "203C":po "0000":POKE_W base+p,xl:p=p+2:REMark move.l #patch_end-start,d0 3340 po "DDC0":REMark adda.l d0,a6 3350 po "99C0":REMark suba.l d0,a4 3360 po "9BC0":REMark suba.l d0,a5 3370 END IF 3380 po "4CDF":po "0FC7":REMark movem.l (a7)+,d0-d2/d6/d7/a0-a3 3382 po "027C":po "D8FF":REMark andi #-$2701,sr - user mode 3390 REMark patch_end: 3420 END IF 3432 IF pflg%=0 THEN 3435 fixTURBO 3436 IF RecogFlg%=0 THEN fixQLIB 3438 END IF 3440 END DEFine 3441 : 3442 REMark DATA CACHE disable subroutine 3445 DATA "2F01","0C28","0010","00A1","632A","4E7A","1002","C340" 3446 DATA "0041","0808","0C28","0030","00A1","6314","4A40","6A02" 3447 DATA "F4B8","4A80","6A06","F478","4A81","6B02","F458","F498" 3448 DATA "4E7B","1002","221F","4E75" 3460 DEFine PROCedure fixTURBO 3470 LOCal p,Q,N,find_loop 3480 RecogFlg%=0 3485 p=9984:IF fl<p THEN p=fl 3490 X=find(LONGINT$(HEX("20087E00"))&LONGINT$(HEX("24790002"))&LONGINT$(HEX("801045EA"))&LONGINT$(HEX("00682A0A")),FILL$(CHR$(255),16),base,0,p) 3660 IF X<>-1 THEN 3665 RecogFlg%=-1 3670 RPORT "TURBO TASK:"&CHR$(10) 3680 unfixTURBO 3690 p=0:CLS#4:CLS#5 3700 REPeat find_loop 3710 IF p>fl THEN EXIT find_loop 3720 FOR N=1 TO 256 3730 temp$=HEX$(PEEK_L(base+p),32) 3740 IF temp$(1 TO 6)=="422E8A" THEN 3750 POKE_L base+p,HEX("422E801D"):DISOUT:RPORT "32 bit fix at $"&HEX$(p,32)&CHR$(10):NoRpc%=NoRpc%+1 3760 ELSE 3770 IF temp$(1 TO 6)=="57EE8A" THEN 3780 POKE_L base+p,HEX("57EE801D"):DISOUT:RPORT "32 bit fix at $"&HEX$(p,32)&CHR$(10):NoRpc%=NoRpc%+1 3790 ELSE 3800 IF temp$(1 TO 6)=="4A2E8A" THEN 3810 POKE_L base+p,HEX("4A2E801D"):DISOUT:RPORT "32 bit fix at $"&HEX$(p,32)&CHR$(10):NoRpc%=NoRpc%+1 3820 END IF 3830 END IF 3840 END IF 3850 p=p+2 3860 IF p>=fl THEN EXIT N 3870 END FOR N 3880 IF p>fl THEN 3890 BLOCK#4;100,10,0,0,4 3900 ELSE 3910 BLOCK#4;INT((p/fl)*100),10,0,0,4 3920 END IF 3930 END REPeat find_loop 3940 END IF 3950 END DEFine 3960 : 3970 DEFine PROCedure fixQLIB 3980 LOCal l,N,i,X 3990 RecogFlg%=0 4000 X=find("Libe"&"rati",FILL$(CHR$(223),8),base,0,fl) 4020 IF X<>-1 THEN 4025 RecogFlg%=-1 4030 REPeat loop 4040 X=X-1:IF PEEK(base+X)=0 THEN EXIT loop 4050 END REPeat loop 4060 l=PEEK_W(base+X) 4070 RESTORE 4880 4080 READ N:l=l-N-N:POKE_W base+X,l:POKE_L base+X+2,STRINGL(":-)"&CHR$(10)):X=X+l+2 4090 FOR i=0 TO N-1 4100 READ temp$:POKE_W base+X+i+i,HEX(temp$) 4110 NEXT i 4120 IF PEEK_W(base+6)<>HEX("4AFB") THEN 4130 RPORT "QLIB CODE:"&CHR$(10) 4140 ELSE 4150 RPORT "QLIB TASK:"&CHR$(10) 4160 END IF 4170 p=X+48:CLS#4:CLS#5 4180 REPeat find_loop 4190 IF p>fl THEN EXIT find_loop 4200 FOR N=1 TO 256 4210 temp$=HEX$(PEEK_L(base+p),32) 4220 IF temp$=="46FC0000" THEN 4230 POKE_L base+p,HEX("027CC0FF"):DISOUT:RPORT "tidying code at $"&HEX$(p,32)&CHR$(10):NoRpc%=NoRpc%+1 4240 ELSE 4250 IF (temp$=="20728004") THEN 4260 POKE_W base+p,HEX("6100"):POKE_W base+p+2,(X+26)-(p+2):DISOUT:RPORT "32 bit fix at $"&HEX$(p,32)&CHR$(10):NoRpc%=NoRpc%+1 4270 ELSE 4280 IF (temp$=="26725004") THEN 4290 POKE_W base+p,HEX("6100"):POKE_W base+p+2,(X+12)-(p+2):DISOUT:RPORT "32 bit fix at $"&HEX$(p,32)&CHR$(10):NoRpc%=NoRpc%+1 4300 ELSE 4310 IF (temp$=="26722004") THEN 4320 POKE_W base+p,HEX("6100"):POKE_W base+p+2,X-(p+2) 4330 IF (HEX$(PEEK_W(base+p+4),32)=="200B") THEN 4340 POKE_W base+p+4,HEX("4E71") 4350 END IF 4360 DISOUT:RPORT "32 bit fix at $"&HEX$(p,32)&CHR$(10):NoRpc%=NoRpc%+1 4370 ELSE 4380 IF (temp$=="26724004") THEN 4390 POKE_W base+p,HEX("6100"):POKE_W base+p+2,(X+6)-(p+2) 4400 IF PEEK(base+p+18)=HEX("67") THEN 4410 IF PEEK(base+p+20)=HEX("65") THEN 4420 i=p+22+PEEK(base+p+21) 4430 IF (PEEK_W(base+i)==HEX("2A0B")) THEN 4440 POKE_W base+i,HEX("2A00") 4450 END IF 4460 END IF 4470 END IF 4480 DISOUT:RPORT "32 bit fix at $"&HEX$(p,32)&CHR$(10):NoRpc%=NoRpc%+1 4490 ELSE 4500 IF (temp$=="20322004") THEN 4510 POKE_W base+p,HEX("6100"):POKE_W base+p+2,(X+32)-(p+2) 4520 IF (PEEK_W(base+p+6)==HEX("2040")) THEN 4530 POKE_W base+p+6,HEX("4E71") 4540 END IF 4550 DISOUT:RPORT "32 bit fix at $"&HEX$(p,32)&CHR$(10):NoRpc%=NoRpc%+1 4560 ELSE 4570 IF (temp$=="24321004") THEN 4580 IF (HEX$(PEEK_L(base+p+4),32)=="6A080C82") AND (HEX$(PEEK_L(base+p+8),32)=="FFFFFFFF") AND (HEX$(PEEK_W(base+p+12),16)=="6710") THEN 4590 p=p+4:POKE_L base+p,HEX("70FFB480"):POKE_L base+p+4,HEX("6714E98A"):POKE_W base+p+8,HEX("E88A") 4600 END IF 4610 DISOUT:RPORT "32 bit fix at $"&HEX$(p,32)&CHR$(10):NoRpc%=NoRpc%+1 4620 ELSE 4630 IF (temp$=="2640586B") THEN 4640 IF (HEX$(PEEK_L(base+p+4),32)=="00120800") AND (HEX$(PEEK_L(base+p+8),32)=="001D6714") THEN 4650 POKE_W base+p,HEX("6100"):POKE_W base+p+2,(X+16)-(p+2):POKE_L base+p+4,HEX("586B0012"):POKE_L base+p+8,HEX("E5886A14") 4660 DISOUT:RPORT "32 bit fix at $"&HEX$(p,32)&CHR$(10):NoRpc%=NoRpc%+1 4670 END IF 4680 END IF 4690 END IF 4700 END IF 4710 END IF 4720 END IF 4730 END IF 4740 END IF 4750 END IF 4760 p=p+2 4770 IF p>=fl THEN EXIT N 4780 END FOR N 4790 IF p>fl THEN 4800 BLOCK#4;100,10,0,0,4 4810 ELSE 4820 BLOCK#4;INT((p/fl)*100),10,0,0,4 4830 END IF 4840 END REPeat find_loop 4850 END IF 4860 END DEFine 4870 : 4880 DATA 24 4890 DATA "2032","2004","600A","2032","4004","6004","2032","5004" 4900 DATA "2640","E988","E888","C18B","4E75","2032","8004","6004" 4910 DATA "2032","2004","2040","E988","E888","C188","4A80","4E75" 4920 : 4930 DEFine PROCedure unfixTURBO 4935 IF STRINGL(versold$)<STRINGL("1.05") THEN 4940 RPORT "removing old patches..."&CHR$(10) 4950 p=0:CLS#4:CLS#5 4960 REPeat find_loop 4970 IF p>fl THEN EXIT find_loop 4980 FOR N=1 TO 256 4990 temp$=HEX$(PEEK_L(base+p),32) 5000 IF temp$=="08920007" THEN 5010 POKE_L base+p,HEX("422E8AD4"):DISOUT:RPORT "old fix removed at $"&HEX$(p,32)&CHR$(10):NoRpc%=NoRpc%+1 5020 ELSE 5030 IF temp$=="660203D2" THEN 5040 POKE_L base+p,HEX("57EE8AD4"):DISOUT:RPORT "old fix removed at $"&HEX$(p,32)&CHR$(10):NoRpc%=NoRpc%+1 5050 ELSE 5060 IF temp$(1 TO 6)=="8AD46D" THEN 5070 p=p+2:POKE base+p,HEX("66"):DISOUT:RPORT "old fix removed at $"&HEX$(p,32)&CHR$(10):NoRpc%=NoRpc%+1 5080 END IF 5090 END IF 5100 END IF 5110 p=p+2 5120 IF p>=fl THEN EXIT N 5130 END FOR N 5140 IF p>fl THEN 5150 BLOCK#4;100,10,0,0,4 5160 ELSE 5170 BLOCK#4;INT((p/fl)*100),10,0,0,4 5180 END IF 5190 END REPeat find_loop 5195 END IF 5200 END DEFine 5210 : 5220 DEFine PROCedure po(a$) 5230 POKE_W base+p,HEX(a$):p=p+2 5240 END DEFine 5250 : 10000 DEFine PROCedure DISOUT 10010 LOCal loop, preLoop, disLoop 10020 LOCal r, Ds, Q, N, c, i 10030 r=Rows/2 10040 Ds=0 10050 FOR i=1 TO r 10060 D(i)=0 10070 END FOR i 10080 Q=p-8*r 10090 IF Q<0 THEN Q=0 10100 REPeat preLoop 10110 N=D68K(base+Q,Q\Buff) 10120 Q=Q+N 10130 Ds=Ds-D(i)+N 10140 D(i)=N 10150 REPeat loop 10160 i=1+(i MOD r) 10170 N=N-6 10180 IF N<=0 THEN EXIT loop 10190 Ds=Ds-D(i) 10200 D(i)=0 10210 END REPeat loop 10220 IF Q>=p THEN EXIT preLoop 10230 END REPeat preLoop 10240 CLS#5 10250 Q=Q-Ds 10260 r=Rows 10270 dflag=0 10280 REPeat disLoop 10290 N=D68K(base+Q,Q\Buff) 10300 i=0:P$=" " 10310 REPeat loop 10320 c=PEEK(Buff+i) 10330 IF c=0 THEN EXIT loop 10340 i=i+1 10350 P$=P$(1 TO LEN(P$))&CHR$(c) 10360 END REPeat loop 10370 IF (Q<=p) AND ((Q+N)>p) THEN 10380 IF dflag AND NOT("tas" INSTR P$(1 TO LEN(P$))) 10390 P$=P$(1 TO 14)&" dc.w $"&P$(11 TO 14)&CHR$(10):dflag=1:N=2 10400 INK#5;4 10410 ELSE 10420 INK#5;7 10430 END IF 10440 ELSE 10450 INK#5;4 10460 dflag="dc." INSTR P$(1 TO LEN(P$)) 10470 END IF 10480 Q=Q+N 10490 r=r-((N+5) DIV 6) 10500 IF r<0 THEN EXIT disLoop 10510 PRINT#5;P$(1 TO LEN(P$)); 10520 END REPeat disLoop 10530 END DEFine 10540 : 10550 DEFine FuNction FILE_CLASS$(i$) 10560 i=0 10570 REPeat check_loop 10580 j="_" INSTR i$(i+1 TO LEN(i$)) 10590 IF j=0 THEN EXIT check_loop 10600 i=i+j 10610 IF i=LEN(i$) THEN RETurn "" 10620 END REPeat check_loop 10630 IF i=0 THEN 10640 j=-1 10650 ELSE 10660 IF (i=5) AND (i$(1 TO i) INSTR "ram1_ram2_flp1_flp2_mdv1_mdv2_") THEN 10670 j=-1 10680 END IF 10690 END IF 10700 IF j<>0 THEN 10710 j="_"&i$(i+1 TO LEN(i$))&"_" INSTR "_BOOT_" 10720 SELect ON j 10730 =1:a$="SuperBASIC boot program" 10740 =REMAINDER :a$="" 10750 END SELect 10760 RETurn a$ 10770 ELSE 10780 a$="" 10790 j=(i$(i TO LEN(i$))&"_") INSTR "_c_h_bas_fth_asm_list_txt_text_scr_doc_aba_prg_grf_hob_arc_zip_font_fnt_boot_asc_screen_dbf_scn_log_task_job_bin_code_rext_inc_" 10800 SELect ON j 10810 =1:a$="C source" 10820 =3:a$="C header file" 10830 =5:a$="SuperBASIC program" 10840 =9:a$="FORTH program" 10850 =13:a$="Assembler source" 10860 =17:a$="Assembler list file" 10870 =123:a$="Assembler include file" 10880 =22,26,77,96:a$="ASCII text file" 10890 =31,81:a$="Screen-save" 10900 =35:a$="QUILL wordprocess document" 10910 =39:a$="ABACUS spreadsheet document" 10920 =43:a$="ARCHIVE program document" 10930 =88:a$="ARCHIVE database file" 10940 =92:a$="ARCHIVE screen layout" 10950 =47:a$="EASEL chart document" 10960 =51:a$="Psion help file" 10970 =55:a$="ARC file archive" 10980 =59:a$="ZIP file archive" 10990 =63,68:a$="Alternative character set" 11000 =72:a$="SuperBASIC boot program" 11010 =100,105:a$="executable TASK" 11020 =109,113:a$="Machine code" 11030 =118:a$="Resident extension code" 11040 =REMAINDER :a$="" 11050 END SELect 11060 END IF 11070 RETurn a$ 11080 END DEFine 11090 : 11100 DEFine FuNction WAITKEY$(Chan%,i$) 11110 LOCal K$(1),i,l,prompt_loop,get_loop 11120 RPORT " (" 11130 i=1:l=LEN(i$) 11140 REPeat prompt_loop 11150 RPORT i$(i):i=i+1 11160 IF i>l THEN EXIT prompt_loop 11170 RPORT "/" 11180 END REPeat prompt_loop 11190 RPORT ")? >" 11200 CURSEN#Chan% 11210 REPeat get_loop 11220 K$=INKEY$(#Chan%,-1) 11230 IF K$ INSTR i$ THEN EXIT get_loop 11240 END REPeat get_loop 11250 CURDIS#Chan% 11260 RPORT K$&CHR$(10) 11270 RETurn K$ 11280 END DEFine 11290 : 11300 DEFine PROCedure RPORT(temp$) 11310 PRINT#3;temp$; 11320 END DEFine 11330 : 11340 DEFine FuNction find(txt$,msk$,base,s,e) 11350 LOCal i,j,K,l 11360 CLS#4 11370 l=-1 11380 i=s 11390 REPeat i_loop 11400 j=0 11410 REPeat j_loop 11420 K=0 11430 REPeat k_loop 11440 IF (PEEK(base+i+j+K)&&CODE(msk$(K+1)))<>(CODE(txt$(K+1))&&CODE(msk$(K+1))) THEN EXIT k_loop 11450 K=K+1 11460 IF K=LEN(txt$) THEN 11470 l=i+j:EXIT i_loop 11480 END IF 11490 END REPeat k_loop 11500 j=j+1 11510 IF j=256 THEN EXIT j_loop 11520 END REPeat j_loop 11530 IF i>=e THEN 11540 BLOCK #4,100,10,0,0,4 11550 ELSE 11560 BLOCK#4;((i-s)/(e-s))*100,10,0,0,4 11570 END IF 11580 i=i+256 11590 IF (i-e)>=256 THEN EXIT i_loop 11600 END REPeat i_loop 11610 RETurn l 11620 END DEFine 11630 :