Power-Programmierung

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

/ Power-Programmierung / CD1.mdf / basic / library / gwbasic / basaid50 / basicai1.bas next >

Wrap

BASIC Source File | 1991-05-15 | 38.4 KB | 1,517 lines

10 GOTO 280 20 GOTO 15160 ' LAST STATEMENT NUMBER IN THE PROGRAM 30 ' 40 'BASICAID (V1.0) ----------- MAY 3 ,1983..12PM EST 50 ' 60 ' 70 ' 80 'BY JAMES MORGAN 90 ' 1749 AMERICANA BLVD 23-G 100 ' ORLANDO FLA. 32809 110 ' 120 '********************************************************************* 130 ' A LIMITED LICENSE IS GRANTED TO ALL USERS OF THIS PROGRAM 140 ' TO MAKE COPIES OF THIS PROGRAM AND DISTRIBUTE THEM TO OTHERS 150 ' ON THE FOLLOWING CONDITIONS: 160 ' 1. THE LIMITED LICENSE NOTICE , AUTHOR INFO. AND 170 ' COPYRIGHT MESSAGES ARE NOT REMOVED OR ALTERED. 180 ' 190 ' 2. NO FEE IS TO BE CHARGED FOR COPYING OR DISTRIBUTING 200 ' THE PROGRAM WITHOUT AN EXPRESSED WRITTEN AGREEMENT 210 ' WITH JAMES MORGAN OR HIS REPRESENTATIVES. 220 ' 230 ' Copyright (c) 1983 by JAMES P MORGAN 240 '********************************************************************* 250 ' 260 ' 270 ' 280 CLOSE 290 CLEAR 300 ON ERROR GOTO 0 310 SCREEN 0,0,0 320 WIDTH 80 330 COLOR 7,0 340 KEY OFF 350 OPTION BASE 1 360 DEFINT A-Z 370 TRUE=-1 380 FALSE= NOT TRUE 390 EJECT=FALSE 400 B$="" 410 D$="" 420 C$="" 430 P$="" 440 SP$="" 450 SB$="" 460 S=0 470 I=0 480 J=0 490 K=0 500 L=0 510 E=0 520 I1=0 530 S1=0 540 SL=0 550 REM1$="REM " 560 IF1$="IF " 570 DATA1$="DATA " 580 APOST$=CHR$(39) 590 BLANK$=CHR$(32) 600 QUOTE$=CHR$(34) 610 COLON$=":" 620 VER$="I" ' CHANGE TO "C" IF PROGRAM COMPILED 630 CR$=CHR$(13) 640 DIM EQ$(21) 650 EQ$(1)="BAD FILE NUMBER" 660 EQ$(2)="FILE NOT FOUND" 670 EQ$(3)="BAD FILE MODE" 680 EQ$(4)="FILE ALREADY OPEN" 690 EQ$(6)="DEVICE I/O ERROR" 700 EQ$(7)="FILE ALREADY EXISTS" 710 EQ$(10)="DISK FULL" 720 EQ$(11)="END OF FILE" 730 EQ$(12)="BAD RECORD NUMBER" 740 EQ$(13)="BAD FILE NAME" 750 EQ$(16)="TOO MANY FILES" 760 EQ$(19)="DISK WRITE PROTECTED" 770 EQ$(20)="DISK NOT READY" 780 EQ$(21)="DISK MEDIA ERROR" 790 DIM ERRMSG$(6) 800 ERRMSG$(1)="INVALID OR MISSING LINE NUMBER OR BINARY FILE USED AS INPUT" 810 ERRMSG$(2)="LINE NUMBER WITH NO BASIC STATEMENT" 820 ERRMSG$(3)="INPUT PROGRAM CONTAINS A BLANK LINE OR ONE WAS GENERATED" 830 ERRMSG$(4)="LITERAL STRING BOUND IN QUOTES MISSING TERMINATING QUOTE" 840 ERRMSG$(5)="CURRENT LINE NUMBER NOT GREATER THAN PREVIOUS LINE NUMBER" 850 ERRMSG$(6)="LINE NUMBER TABLE IS FULL, TOO MANY LOGIC BRANCH REFERENCES" 860 FREECNT=0 870 BEEPCNT=3 880 BEEPLOOP=600 890 LPRNT=FALSE 900 GOSUB 10600 'TOGGLE CAPSLOCK ON 910 GOSUB 9040 'WHAT KIND OF VIDEO ADAPTER 920 GOSUB 9190 'REQUEST RUNTIME OPTIONS 930 DIM D$(2) 940 D$(1)="A:" 950 D$(2)="B:" 960 START$="" 970 FINISH$="" 980 S=1 990 ROWLINES=10 1000 PAGESIZE=50 1010 FREELMT=2 1020 LINECNT=0 1030 PRVLNUM=-32768! 1040 ' 1050 IF RUNTYPE < 3 GOTO 1180 1060 IF RUNTYPE>4 GOTO 1180 1070 READ RESCNT 1080 DIM RESWRD$(RESCNT) ' RESWRD$(153) FIXED IF COMPILED 1090 DIM WORDFLAG(RESCNT) ' WORDFLAG(153) FIXED IF COMPILED 1100 FOR I=1 TO RESCNT 1110 READ RESWRD$(I),WORDFLAG(I) 1120 NEXT 1130 ' 1140 DNMCNT=100 1150 IF RUNTYPE=4 THEN DNMCNT=RESCNT 1160 DIM DATANAME$(DNMCNT) ' DATANAME$(100) FIXED IF COMPILED 1170 ' 1180 IF RUNTYPE < 2 GOTO 1290 1190 NUMLINES=1 1200 DIMLINE=100 1210 IF RUNTYPE=4 THEN DIMLINE=RESCNT 1220 YCNT=50 1230 IF ACTUAL.RUNTYPE=5 THEN YCNT=5 1240 DIM LINENOS(DIMLINE,YCNT) ' LINENOS(100,50) FIXED IF COMPILED 1250 FOR X=1 TO DIMLINE 1260 LINENOS(X,1)=-32768! 1270 NEXT 1280 ' 1290 CLS 1300 ON ERROR GOTO 0 1310 LOCATE 2,1,1 1320 PRINT "ENTER THE BASIC PROGRAM NAME TO BE PROCESSED" 1330 PRINT 1340 GOSUB 9660 'FLUSH ALL KEYBOARD BUFFERS 1350 INPUT "PROGRAM NAME : ",BASPGM$ 1360 IF LEN(BASPGM$) < 1 GOTO 1290 1370 IF LEN(BASPGM$) > 8 GOTO 1290 1380 LOCATE 5,1,0 1390 FOR I = 1 TO 24 - CSRLIN 1400 PRINT STRING$(79," ") 1410 NEXT 1420 LOCATE 6,1,1 1430 BEEP 1440 PRINT "WHAT DRIVE IS THE FILE ON, A OR B, (PRESS ENTER FOR DEFAULT DRIVE)" 1450 PRINT 1460 PRINT "DRIVE : "; 1470 GOSUB 9660 1480 DRIVE$=INKEY$ 1490 IF DRIVE$="" GOTO 1480 1500 IF DRIVE$=CR$ THEN DRIVE$="":GOTO 1620 1510 IF LEN(DRIVE$) > 1 GOTO 1380 1520 IF DRIVE$=CHR$(27) GOTO 13450 1530 PRINT DRIVE$; 1540 IF DRIVE$="A" GOTO 1580 1550 IF DRIVE$="B" GOTO 1610 1560 GOTO 1380 1570 ' 1580 DRIVE$=D$(1) 1590 GOTO 1620 1600 ' 1610 DRIVE$=D$(2) 1620 DSN$=DRIVE$+BASPGM$+".BAS" 1630 ON ERROR GOTO 4450 1640 PRINT 1650 FILES DSN$ 1660 ON ERROR GOTO 0 1670 OPEN DSN$ FOR INPUT AS 1 1680 IF RUNTYPE <>1 GOTO 1730 1690 OUTFILE$="TEMPFILE.BAS" 1700 REASON$="EXPANDING PROGRAM" 1710 GOSUB 10100 1720 ' 1730 START$=TIME$ 1740 LOCATE 25,1,0 1750 PRINT "PROCESSING LINE NUMBER = "; 1760 ' 1770 IF EOF(1) GOTO 4870 1780 GOSUB 1920 ' READ INPUT BASIC PROGRAM 1790 FREECNT=FREECNT + 1 1800 IF FREECNT > FREELMT THEN FREECNT=0:FREE!=FRE("") 1810 L=LEN(B$) 1820 GOSUB 4070 ' FIND END OF THE BASIC INPUT LINE 1830 E=BEND 1840 GOSUB 2950 ' ISOLATE LINE NUMBER AND FIND FIRST STATEMENT 1850 IF BEGIN=0 GOTO 1770 1860 GOSUB 8980 ' PRINT LINE NUMBER CURRENTLY PROCESSING 1870 GOSUB 2190 ' SEPARATE LINE INTO ONE OR MORE STATEMENTS 1880 GOTO 1770 1890 ' 1900 ' READ THE BASIC PROGRAM TO BE EXPANDED/COMPRESSED/XREFERENCED 1910 ' 1920 ON ERROR GOTO 1990 1930 LINE INPUT#1,B$ 1940 ON ERROR GOTO 0 1950 RETURN 1960 ' 1970 ' ERROR HANDLING ROUTINE ON THE INPUT (BASIC PROGRAM) 1980 ' 1990 ROW=CSRLIN 2000 COLUMN=POS(0) 2010 GOSUB 4600 'DETERMINE TYPE OF FILE ERROR 2020 RESUME 2030 2030 ON ERROR GOTO 0 2040 LOCATE 24,1,1 2050 COLOR 15 2060 PRINT "READ ON BASIC PROGRAM FAILED. ";M$ 2070 M$=" " 2080 PRINT "CORRECT PROBLEM AND PRESS ANY KEY TO CONTINUE"; 2090 GOSUB 9660 2100 KEYIN$=INKEY$ 2110 IF LEN(KEYIN$)=0 GOTO 2100 2120 IF KEYIN$=CHR$(27) GOTO 13450 2130 COLOR 7 2140 LOCATE ROW,COLUMN,0 2150 GOTO 1920 2160 ' 2170 ' SEPARATE BASIC STATEMENTS INTO ONE OR MORE STATEMENTS 2180 ' 2190 S=BEGIN 2200 FOR I=S TO E 2210 C$=MID$(B$,I,1) 2220 IF C$=QUOTE$ GOTO 4340 ' START OF NON-NUMERIC CHAR. STRING FOUND 2230 IF C$=APOST$ GOTO 2760 ' TERMINATING REMARK ON THE LINE 2240 IF C$<>COLON$ GOTO 2640 2250 ' 2260 ' A ":" WAS FOUND INDICATING THAT THERE ARE MULTIPLE STATEMENTS ON THIS LINE 2270 ' 2280 IF I-S < 1 GOTO 2460 ' THROW AWAY ":" THAT ARE NEXT TO EACH OTHER 2290 P$=MID$(B$,S,I-S) 2300 IF RUNTYPE = 1 GOTO 2330 2310 GOSUB 5590 'ISOLATE DATA NAMES AND LINE NUMBERS 2320 IF RUNTYPE <> 1 GOTO 2370 2330 P$=CURLNUM$+" "+P$ 2340 IF LPRNT THEN LPRINT P$ 2350 GOSUB 3720 'WRITE A NEW BASIC LINE 2360 LINENO=LINENO + 1 2370 GOSUB 8980 2380 CURLNUM$=STR$(LINENO + 32767) 2390 ITSLEN=LEN(CURLNUM$) 2400 ITSLEN=ITSLEN - 1 2410 CURLNUM$=RIGHT$(CURLNUM$,ITSLEN) 2420 PRVLNUM=LINENO 2430 ' 2440 ' THE ":" WAS FOUND, NOW SCAN FOR FIRST NON.BLANK CHAR. 2450 ' 2460 S=I+1 2470 IF E-S < 1 GOTO 2740 'WE ARE THRU WITH THIS LINE 2480 C$=MID$(B$,S,1) 2490 IF C$<=BLANK$ THEN I=S:GOTO 2460 2500 ' 2510 ' CHECK IF "REM" OR "IF" STATEMENT IMBEDDED ON THIS LINE 2520 ' 2530 IF (C$<>"I") AND (C$<>"R") GOTO 2200 2540 IF C$<>"I" GOTO 2600 2550 C$=MID$(B$,S,3) 2560 GOSUB 2790 2570 IF C$=IF1$ GOTO 2760 2580 GOTO 2200 2590 ' 2600 C$=MID$(B$,S,4) 2610 GOSUB 3770 2620 IF C$=REM1$ GOTO 2760 2630 GOTO 2200 2640 NEXT I 2650 ' 2660 P$=MID$(B$,S,I-S) 2670 IF RUNTYPE = 1 GOTO 2700 2680 GOSUB 5590 'ISOLATE DATA NAMES AND LINE NUMBERS 2690 IF RUNTYPE <> 1 GOTO 2730 2700 P$=CURLNUM$+" "+P$ 2710 IF LPRNT THEN LPRINT P$ 2720 GOSUB 3720 ' WRITE THE NEW BASIC LINE 2730 GOSUB 8980 2740 RETURN 2750 ' 2760 I=E+1 2770 GOTO 2660 2780 ' 2790 IF LEN(C$)<2 THEN RETURN 2800 IF MID$(C$,1,2)<>"IF" THEN RETURN 2810 IF LEN(C$)<3 THEN RETURN 2820 IF MID$(C$,3,1)=" " THEN RETURN 2830 IF MID$(C$,3,1)="." THEN RETURN 2840 IF ASC(MID$(C$,3,1))<48 GOTO 2890 2850 IF ASC(MID$(C$,3,1))>90 GOTO 2890 2860 IF (ASC(MID$(C$,3,1))>57) AND (ASC(MID$(C$,3,1))<65) GOTO 2890 2870 RETURN 2880 ' 2890 C$="IF " 2900 RETURN 2910 ' 2920 ' ISOLATE LINE NUMBER AND FIND START OF BASIC STATEMENT(S) 2930 ' 2940 ' FIND THE FIRST NON-BLANK CHAR. 2950 BEGIN=0 2960 CURLNUM$="" 2970 FOR I = 1 TO E 2980 C$=MID$(B$,I,1) 2990 IF C$>BLANK$ GOTO 3010 3000 NEXT I 3010 S=I 3020 P$="" 3030 ' 3040 ' SCAN UNTIL FIRST NON-NUMERIC CHAR (BUILDING LINE NUMBER) 3050 ' 3060 FOR I = S TO E 3070 C$=MID$(B$,I,1) 3080 IF C$<"0" GOTO 3130 3090 IF C$>"9" GOTO 3130 3100 P$=P$ + C$ 3110 NEXT I 3120 ' DO WE HAVE A INVALID LINE NUMBER 3130 IF I=E THEN ERRNO=1:GOTO 4260 3140 IF LEN(P$)<1 THEN ERRNO=1:GOTO 4260 3150 IF LEN(P$)>5 THEN ERRNO=1:GOTO 4260 3160 CURLNUM$=P$ 3170 CURLINE!=VAL(CURLNUM$) 3180 LINENO=CURLINE! - 32767 3190 IF RUNTYPE <> 1 GOTO 3210 3200 IF LINENO <= PRVLNUM THEN ERRNO=5:GOTO 4260 3210 PRVLNUM=LINENO 3220 ' 3230 ' SCAN UNTIL WE FIND THE FIRST NON-BLANK CHAR (FIND FIRST BASIC STATEMENT) 3240 ' 3250 S=I 3260 FOR I=S TO E 3270 C$=MID$(B$,I,1) 3280 IF C$>BLANK$ GOTO 3310 3290 NEXT I 3300 IF I=E THEN ERRNO=2:GOTO 4260 3310 BEGIN=I 3320 IF C$=COLON$ GOTO 3550 ' REMOVE ALL LEADING ":" 3330 IF C$=APOST$ GOTO 3580 ' THIS MUST BE A COMMENT STATEMENT 3340 ' 3350 ' CHECK IF THE LINE BEGINS AS A "REM" OR "DATA" OR "IF" STATEMENT 3360 ' 3370 IF (C$<>"R") AND (C$<>"D") AND (C$<>"I") THEN RETURN 3380 IF C$<>"R" GOTO 3440 3390 C$=MID$(B$,I,4) 3400 GOSUB 3770 3410 IF C$=REM1$ GOTO 3580 3420 RETURN 3430 ' 3440 IF C$<>"I" GOTO 3500 3450 C$=MID$(B$,I,3) 3460 GOSUB 2790 3470 IF C$=IF1$ GOTO 3580 3480 RETURN 3490 ' 3500 C$=MID$(B$,I,5) 3510 GOSUB 3910 3520 IF C$=DATA1$ GOTO 3580 3530 RETURN 3540 ' 3550 MID$(B$,I,1)=BLANK$ 3560 GOTO 3250 3570 ' 3580 BEGIN=0 3590 S=I 3600 P$=MID$(B$,S) 3610 IF RUNTYPE = 1 GOTO 3640 3620 GOSUB 5590 'ISOLATE DATA NAMES AND LINE NUMBERS 3630 IF RUNTYPE <> 1 GOTO 3670 3640 P$=CURLNUM$+" "+P$ 3650 IF LPRNT THEN LPRINT P$ 3660 GOSUB 3720 ' CREATE (WRITE) THE NEW BASIC LINE 3670 GOSUB 8980 3680 RETURN 3690 ' 3700 ' CREATE (WRITE) THE NEW BASIC LINE(S) 3710 ' 3720 ON ERROR GOTO 4670 3730 PRINT#2,P$ 3740 ON ERROR GOTO 0 3750 RETURN 3760 ' 3770 IF LEN(C$)<3 THEN RETURN 3780 GOSUB 4190 3790 IF MID$(C$,1,3)<>"REM" THEN RETURN 3800 IF LEN(C$)=3 GOTO 3880 3810 IF MID$(C$,4,1)=" " THEN RETURN 3820 IF MID$(C$,4,1)="." THEN RETURN 3830 IF ASC(MID$(C$,4,1))<48 GOTO 3880 3840 IF ASC(MID$(C$,4,1))>90 GOTO 3880 3850 IF (ASC(MID$(C$,4,1))>57) AND (ASC(MID$(C$,4,1))<65) GOTO 3880 3860 RETURN 3870 ' 3880 C$="REM " 3890 RETURN 3900 ' 3910 IF LEN(C$)<4 THEN RETURN 3920 GOSUB 4190 3930 IF MID$(C$,1,4)<>"DATA" THEN RETURN 3940 IF LEN(C$)=4 GOTO 4020 3950 IF MID$(C$,5,1)=" " THEN RETURN 3960 IF MID$(C$,5,1)="." THEN RETURN 3970 IF ASC(MID$(C$,5,1))<48 GOTO 4020 3980 IF ASC(MID$(C$,5,1))>90 GOTO 4020 3990 IF (ASC(MID$(C$,5,1))>57) AND (ASC(MID$(C$,5,1))<65) GOTO 4020 4000 RETURN 4010 ' 4020 C$="DATA " 4030 RETURN 4040 ' 4050 ' FIND TRUE END OF A STATEMENT LINE 4060 ' 4070 GOSUB 13000 'CHECK FOR DOUBLE QUOTES, ALSO COMPRESS INPUT LINE 4080 FOR I=L TO 1 STEP -1 ' START AT END OF THE LINE 4090 C$=MID$(B$,I,1) 4100 IF C$<>BLANK$ GOTO 4120 4110 NEXT I 4120 IF I=1 THEN ERRNO=3:GOTO 4260 4130 IF I=L GOTO 4150 4140 B$=MID$(B$,1,I) 4150 L=LEN(B$) 4160 BEND=I 4170 RETURN 4180 ' 4190 FOR J=1 TO LEN(C$) 4200 MID$(C$,J,1)=CHR$(ASC(MID$(C$,J,1)) AND 95) 4210 NEXT 4220 RETURN 4230 ' 4240 ' ALMOST ALL ERRORS DETECTED WHILE SCANNING PROGRAM SHOULD COME TO HERE 4250 ' 4260 PRINT 4270 PRINT "error - check logic or data" 4280 PRINT 4290 PRINT ERRMSG$(ERRNO) 4300 GOTO 13450 4310 ' 4320 ' SCAN OVER STRING LITERALS BOUND IN QUOTES 4330 ' 4340 K=I+1 4350 FOR J=K TO E 4360 C$=MID$(B$,J,1) 4370 IF C$=QUOTE$ GOTO 4420 4380 NEXT J 4390 PRINT:PRINT "PROGRAM TRAP REACHED" 4400 STOP 4410 END 4420 I=J 4430 GOTO 2640 4440 ' 4450 PRINT 4460 PRINT "** ERROR ";ERR;" ACCESSING ";DSN$ 4470 IF ERR=53 THEN PRINT DSN$;" NOT ON DISKETTE" 4480 RESUME 4490 4490 ON ERROR GOTO 0 4500 PRINT 4510 PRINT "PRESS ANY KEY TO CONTINUE" 4520 GOSUB 9660 4530 KEYIN$=INKEY$ 4540 IF KEYIN$="" GOTO 4530 4550 IF KEYIN$=CHR$(27) GOTO 13450 4560 GOTO 1290 4570 ' 4580 ' WHAT TYPE OF BASIC ERROR WAS FOUND, MOSTLY CONCERNED WITH FILE ERRORS 4590 ' 4600 IF ERR<52 THEN M$="":GOTO 4620 4610 M$=EQ$(ERR-51) 4620 IF M$="" THEN M$="BASIC ERROR "+STR$(ERR) 4630 RETURN 4640 ' 4650 ' ERROR HANDLING ROUTINES FOR THE OUTPUT BASIC PROGRAM 4660 ' 4670 ROW=CSRLIN 4680 COLUMN=POS(0) 4690 GOSUB 4600 4700 RESUME 4710 4710 ON ERROR GOTO 0 4720 LOCATE 24,1,1 4730 COLOR 15 4740 PRINT "EXPANDED PROGRAM WRITE FAILED. ";M$ 4750 M$=" " 4760 PRINT "CORRECT PROBLEM AND PRESS ANY KEY TO CONTINUE"; 4770 GOSUB 9660 4780 KEYIN$=INKEY$ 4790 IF LEN(KEYIN$)=0 GOTO 4780 4800 IF KEYIN$=CHR$(27) GOTO 13450 4810 COLOR 7 4820 LOCATE ROW,COLUMN,0 4830 GOTO 3720 4840 ' 4850 ' END-OF-FILE ROUTINES 4860 ' 4870 CLS 4880 IF RUNTYPE <> 2 GOTO 5030 4890 GOSUB 7860 ' SORT THE LINE NUMBER REFERENCES 4900 IF ACTUAL.RUNTYPE=5 GOTO 5100 4910 GOSUB 8170 ' PRINT HEADINGS FOR LINE NUMBER REFERENCES 4920 FOR X=1 TO DIMLINE 4930 IF LINENOS(X,1)=-32768! GOTO 4950 4940 GOSUB 5280 ' PRINT LINE NUMBER REFERENCES 4950 NEXT 4960 FOR I=1 TO 2 4970 LPRINT 4980 NEXT 4990 LPRINT "NOTE: LINE NUMBER APPLIES TO ANY line-number REFERENCED BY A :" 5000 LPRINT 5010 LPRINT " GOTO, GOSUB, RESUME, RESTORE, THEN, ELSE OR ERL STATEMENT" 5020 LPRINT 5030 IF RUNTYPE < 3 GOTO 5100 5040 GOSUB 8500 ' SORT THE DATA NAME TABLE 5050 GOSUB 8810 ' PRINT THE LISTING HEADINGS 5060 FOR X=1 TO DIMLINE 5070 IF DATANAME$(X)="" GOTO 5090 5080 GOSUB 5280 ' PRINT THE LINE NUMBER REFERENCES 5090 NEXT 5100 PRINT 5110 FINISH$=TIME$ 5120 PRINT "PROGRAM START TIME = ";START$ 5130 PRINT "PROGRAM FINISH TIME = ";FINISH$ 5140 PRINT DSN$;" SUCCESSFULLY PROCESSED..." 5150 PRINT 5160 IF ACTUAL.RUNTYPE=5 GOTO 10700 5170 GOSUB 5200 'RESET PRINTER 5180 GOTO 13450 5190 ' 5200 IF NOT EJECT GOTO 5230 5210 LPRINT CHR$(18) + CHR$(12) 5220 WIDTH "LPT1:",80 5230 RETURN 5240 ' 5250 ' 5260 ' PRINT LINE NUMBER REFERENCES 5270 ' 5280 TOCNT=LINENOS(X,2) 5290 FROMLINE=LINENOS(X,3) 5300 TABPOS=3 5310 IF RUNTYPE=2 GOTO 5340 5320 IF LINECNT > PAGESIZE THEN GOSUB 8810 5330 GOTO 5350 5340 IF LINECNT > PAGESIZE THEN GOSUB 8170 5350 LPRINT 5360 IF RUNTYPE = 2 GOTO 5400 5370 LPRINT DATANAME$(X) 5380 LINECNT=LINECNT + 1 5390 GOTO 5420 5400 CURLINE!=LINENOS(X,1) + 32767 5410 LPRINT CURLINE!; 5420 TABPOS=20 5430 L=1 5440 FOR I=1 TO ROWLINES 5450 CURLINE!=LINENOS(FROMLINE,L+3) + 32767 5460 LPRINT TAB(TABPOS) CURLINE!; 5470 L=L + 1 5480 IF L > TOCNT GOTO 5510 5490 TABPOS=TABPOS + 8 5500 NEXT I 5510 TABPOS=20 5520 LPRINT 5530 LINECNT=LINECNT + 2 5540 IF L <= TOCNT GOTO 5440 5550 RETURN 5560 ' 5570 ' ISOLATE DATANAMES/RESERVED WORDS AND LINE NUMBERS 5580 ' 5590 SP$=P$ 5600 SL=LEN(SP$) 5610 IF MID$(SP$,1,1) = APOST$ GOTO 5830 5620 GOSUB 5910 5630 IF MID$(SP$,1,4) = REM1$ GOTO 5830 5640 GOSUB 6050 5650 IF MID$(SP$,1,5)=DATA1$ GOTO 5870 5660 GOSUB 6210 'REMOVE STRING LITERALS 5670 FOR I1 = 1 TO SL 5680 V=ASC(MID$(SP$,I1,1)) 5690 IF V = 46 GOTO 5780 ' "." 5700 IF V = 38 GOTO 5780 ' "&" 5710 IF V < 48 GOTO 5770 ' "0" 5720 IF V > 90 GOTO 5770 ' "Z" 5730 IF V > 64 GOTO 5780 ' "@" 5740 IF V > 57 GOTO 5770 ' "9" 5750 GOTO 5780 5760 ' 5770 MID$(SP$,I1,1)=BLANK$ 5780 NEXT I1 5790 GOSUB 6450 5800 GOSUB 6530 5810 RETURN 5820 ' 5830 SP$="REM" 5840 SL=LEN(SP$) 5850 GOTO 5800 5860 ' 5870 SP$="DATA" 5880 SL=LEN(SP$) 5890 GOTO 5800 5900 ' 5910 IF LEN(SP$)<3 THEN RETURN 5920 IF MID$(SP$,1,3)<>"REM" THEN RETURN 5930 IF LEN(SP$)=3 GOTO 6010 5940 IF MID$(SP$,4,1)=" " THEN RETURN 5950 IF MID$(SP$,4,1)="." THEN RETURN 5960 IF ASC(MID$(SP$,4,1))<48 GOTO 6010 5970 IF ASC(MID$(SP$,4,1))>90 GOTO 6010 5980 IF (ASC(MID$(SP$,4,1))>57) AND (ASC(MID$(SP$,4,1))<65) GOTO 6010 5990 RETURN 6000 ' 6010 SP$="REM " 6020 SL=LEN(SP$) 6030 RETURN 6040 ' 6050 IF LEN(SP$)<4 THEN RETURN 6060 IF MID$(SP$,1,4)<>"DATA" THEN RETURN 6070 IF LEN(SP$)=4 GOTO 6150 6080 IF MID$(SP$,5,1)=" " THEN RETURN 6090 IF MID$(SP$,5,1)="." THEN RETURN 6100 IF ASC(MID$(SP$,5,1))<48 GOTO 6150 6110 IF ASC(MID$(SP$,5,1))>90 GOTO 6150 6120 IF (ASC(MID$(SP$,5,1))>57) AND (ASC(MID$(SP$,5,1))<65) GOTO 6150 6130 RETURN 6140 ' 6150 SP$="DATA " 6160 SL=LEN(SP$) 6170 RETURN 6180 ' 6190 ' REMOVE STRING LITERALS BOUND IN QUOTES AND COMMENTS 6200 ' 6210 S1=1 6220 FOR I1=S1 TO SL 6230 C$=MID$(SP$,I1,1) 6240 IF C$=QUOTE$ GOTO 6290 6250 IF C$=APOST$ GOTO 6410 6260 NEXT I1 6270 GOTO 6450 6280 ' 6290 MID$(SP$,I1,1)=BLANK$ 6300 FOR I1=I1 TO SL 6310 C$=MID$(SP$,I1,1) 6320 IF C$=QUOTE$ GOTO 6370 6330 MID$(SP$,I1,1)=BLANK$ 6340 NEXT I1 6350 GOTO 6450 6360 ' 6370 MID$(SP$,I1,1)=BLANK$ 6380 S1=I1 6390 GOTO 6220 6400 ' 6410 MID$(SP$,I1,1)=BLANK$ 6420 SP$=MID$(SP$,1,I1) 6430 SL=LEN(SP$) 6440 ' 6450 FOR I1=SL TO 1 STEP -1 6460 C$=MID$(SP$,I1,1) 6470 IF C$ <> BLANK$ GOTO 6490 6480 NEXT I1 6490 SP$=MID$(SP$,1,I1) 6500 SL=LEN(SP$) 6510 RETURN 6520 ' 6530 S1=1 6540 GOSUB 7010 'GET A WORD 6550 IF C$="" GOTO 6630 6560 IF C$< "A" GOTO 6540 6570 IF RUNTYPE = 2 GOTO 6870 6580 GOSUB 6670 'BINARY SEARCH OF RESERVED WORD TABLE 6590 IF FOUND=1 GOTO 6870 6600 IF RUNTYPE <> 3 GOTO 6540 6610 GOSUB 7400 'ADD DATANAMES/LINENOS TO THEIR TABLES 6620 GOTO 6540 6630 RETURN 6640 ' 6650 ' BINARY SEARCH OF RESERVED WORD TABLE 6660 ' 6670 FOUND=0 6680 LOW!=1 6690 HIGH!=RESCNT 6700 HALF=FIX((HIGH!/2) + .5) 6710 NOW=HALF 6720 IF C$=RESWRD$(NOW) GOTO 6840 6730 IF C$ < RESWRD$(NOW) GOTO 6810 6740 LOW!=NOW + 1 6750 IF LOW! > HIGH! GOTO 6850 6760 IF HIGH! < LOW! GOTO 6850 6770 NUW=FIX((HIGH!-LOW!)/2! + .5) 6780 NOW=NUW+LOW! 6790 GOTO 6720 6800 ' 6810 HIGH!=NOW - 1 6820 GOTO 6750 6830 ' 6840 FOUND=1 6850 RETURN 6860 ' 6870 IF C$="GOTO" GOTO 7260 6880 IF C$="GOSUB" GOTO 7260 6890 IF C$="RESUME" GOTO 7140 6900 IF C$="THEN" GOTO 7140 6910 IF C$="ELSE" GOTO 7140 6920 IF C$="ERL" GOTO 7140 6930 IF C$="RESTORE" GOTO 7140 6940 IF RUNTYPE <> 4 GOTO 6540 6950 IF WORDFLAG(NOW) = 0 GOTO 6540 6960 GOSUB 7400 6970 GOTO 6540 6980 ' 6990 ' GET A WORD 7000 ' 7010 C$="" 7020 FOR I1 = S1 TO SL 7030 C$=MID$(SP$,I1,1) 7040 IF C$<>BLANK$ GOTO 7060 7050 NEXT I1 7060 C$="" 7070 FOR I1=I1 TO SL 7080 IF MID$(SP$,I1,1)=BLANK$ GOTO 7110 7090 C$=C$+MID$(SP$,I1,1) 7100 NEXT I1 7110 S1=I1 7120 RETURN 7130 ' 7140 IF RUNTYPE <> 4 GOTO 7170 7150 IF WORDFLAG(NOW) = 0 GOTO 7170 7160 GOSUB 7400 7170 S1=I1 7180 IF RUNTYPE <> 2 GOTO 6540 7190 GOSUB 7010 7200 IF C$="" GOTO 7240 7210 IF ASC(C$) > 64 GOTO 6570 7220 GOSUB 7400 7230 GOTO 6540 7240 RETURN 7250 ' 7260 IF RUNTYPE <> 4 GOTO 7290 7270 IF WORDFLAG(NOW) = 0 GOTO 7290 7280 GOSUB 7400 7290 S1=I1 7300 IF RUNTYPE <> 2 GOTO 6540 7310 GOSUB 7010 7320 IF C$="" GOTO 7360 7330 IF ASC(C$) > 64 GOTO 6570 7340 GOSUB 7400 7350 GOTO 7310 7360 RETURN 7370 ' 7380 ' ADD DATENAMES AND/OR LINE NUMBERS TO THEIR RESPECTIVE TABLES 7390 ' 7400 IF RUNTYPE <> 4 GOTO 7470 7410 X=NOW 7420 DATANAME$(X)=C$ 7430 NUMLINES=RESCNT 7440 LINETO=X 7450 GOTO 7680 7460 ' 7470 IF RUNTYPE <> 2 GOTO 7580 7480 LINETO=VAL(C$) - 32767 7490 FOR X=1 TO DIMLINE 7500 IF LINENOS(X,1)=LINETO GOTO 7560 7510 IF LINENOS(X,1) = -32768! GOTO 7550 7520 NEXT X 7530 GOTO 7810 7540 ' 7550 NUMLINES=X 7560 GOTO 7680 7570 ' 7580 IF RUNTYPE <> 3 GOTO 4260 7590 FOR X=1 TO DNMCNT 7600 IF DATANAME$(X) = "" GOTO 7650 7610 IF DATANAME$(X) = C$ GOTO 7670 7620 NEXT X 7630 GOTO 7810 7640 ' 7650 DATANAME$(X) = C$ 7660 NUMLINES=X 7670 LINETO=X 7680 LINENOS(X,1)=LINETO 7690 LINENOS(X,3)=X 7700 Z=LINENOS(X,2) 7710 Y=1 7720 IF Z=0 GOTO 7770 7730 IF Z=1 AND ACTUAL.RUNTYPE=5 GOTO 7790 7740 FOR Y=1 TO Z 7750 IF LINENOS(X,Y + 3)=LINENO GOTO 7790 7760 NEXT Y 7770 LINENOS(X,Y + 3)=LINENO 7780 LINENOS(X,2)=LINENOS(X,2) + 1 7790 RETURN 7800 ' 7810 ERRNO=6 7820 GOTO 4260 7830 ' 7840 ' SORT LINE NUMBER TABLE 7850 ' 7860 PRINT "START - LINE NUMBER TABLE SORT : ";TIME$ 7870 GOSUB 9120 7880 ROW=CSRLIN 7890 COLUMN=POS(0) 7900 LOCATE 25,1,0 7910 PRINT STRING$(79," "); 7920 LOCATE 25,1,0 7930 PRINT "** SORTING"; 7940 FOR X=1 TO NUMLINES - 1 7950 FOR Y=X+1 TO NUMLINES 7960 IF LINENOS(X,1) < LINENOS(Y,1) GOTO 8000 7970 SWAP LINENOS(X,1),LINENOS(Y,1) 7980 SWAP LINENOS(X,2),LINENOS(Y,2) 7990 SWAP LINENOS(X,3),LINENOS(Y,3) 8000 NEXT 8010 LOCATE 25,1,0 8020 PRINT " "; 8030 LOCATE 25,1,0 8040 PRINT "** SORTING"; 8050 NEXT 8060 LOCATE 25,1,0 8070 PRINT STRING$(79," "); 8080 LOCATE ROW,COLUMN,1 8090 PRINT 8100 PRINT "FINISH- LINE NUMBER TABLE SORT : ";TIME$ 8110 GOSUB 9120 8120 PRINT 8130 RETURN 8140 ' 8150 ' PRINT HEADINGS FOR LINE NUMBER CROSS REFERENCE 8160 ' 8170 ON ERROR GOTO 8310 8180 LPRINT CHR$(13)+CHR$(12) 8190 LPRINT "PROGRAM : ";DSN$ TAB(75) DATE$;" @ ";TIME$ 8200 LPRINT 8210 LPRINT TAB(35) "LINE NUMBER CROSS-REFERENCE" 8220 LPRINT 8230 LPRINT " LINE" 8240 LPRINT "NUMBER -------REFERENCES------REFERENCES------REFERENCES------REFERENCES------" 8250 ON ERROR GOTO 0 8260 LINECNT=8 8270 RETURN 8280 ' 8290 ' ERROR HANDLING ROUTINE FOR THE PRINTER 8300 ' 8310 IF ERR=24 THEN RESUME 8320 IF ERR<>27 THEN 8440 8330 CLS 8340 PRINT CHR$(7)+CHR$(7) 8350 PRINT 8360 PRINT "PRINTER NOT READY OR OUT OF PAPER" 8370 PRINT "READY THE PRINTER, AND PRESS ANY KEY TO CONTINUE" 8380 GOSUB 9660 8390 KEYIN$=INKEY$ 8400 IF KEYIN$="" GOTO 8390 8410 IF KEYIN$=CHR$(27) GOTO 13450 8420 RESUME 8430 ' 8440 PRINT 8450 PRINT "BASIC ERROR : ";ERR;" AT LINE NO. : ";ERL 8460 GOTO 13450 8470 ' 8480 ' SORT DATANAME TABLE 8490 ' 8500 IF RUNTYPE = 4 GOTO 8770 8510 PRINT "START - DATA NAME TABLE SORT : ";TIME$ 8520 GOSUB 9120 8530 ROW=CSRLIN 8540 COLUMN=POS(0) 8550 LOCATE 25,1,0 8560 PRINT STRING$(79," "); 8570 LOCATE 25,1,0 8580 PRINT "** SORTING"; 8590 FOR X=1 TO NUMLINES - 1 8600 FOR Y=X+1 TO NUMLINES 8610 IF DATANAME$(X)<DATANAME$(Y) GOTO 8660 8620 SWAP DATANAME$(X),DATANAME$(Y) 8630 SWAP LINENOS(X,1),LINENOS(Y,1) 8640 SWAP LINENOS(X,2),LINENOS(Y,2) 8650 SWAP LINENOS(X,3),LINENOS(Y,3) 8660 NEXT 8670 LOCATE 25,1,0 8680 PRINT " "; 8690 LOCATE 25,1,0 8700 PRINT "** SORTING"; 8710 NEXT 8720 LOCATE 25,1,0 8730 PRINT STRING$(79," "); 8740 LOCATE ROW,COLUMN,1 8750 PRINT "FINISH- DATA NAME TABLE SORT : ";TIME$ 8760 GOSUB 9120 8770 RETURN 8780 ' 8790 ' PRINT HEADINGS FOR THE DATANAME CROSS REFERENCE 8800 ' 8810 ON ERROR GOTO 8310 8820 LPRINT CHR$(13)+CHR$(12) 8830 LPRINT "PROGRAM : ";DSN$ TAB(75) DATE$;" @ ";TIME$ 8840 LPRINT 8850 IF RUNTYPE=3 THEN LPRINT TAB(35) "DATA NAME CROSS-REFERENCE" 8860 IF RUNTYPE=4 THEN LPRINT TAB(30) "RESERVED WORD CROSS-REFERENCE" 8870 LPRINT 8880 IF RUNTYPE=3 THEN LPRINT " DATA" 8890 IF RUNTYPE=4 THEN LPRINT " RESERVED" 8900 IF RUNTYPE=3 THEN LPRINT " NAME ------REFERENCES------REFERENCES------REFERENCES------REFERENCES------" 8910 IF RUNTYPE=4 THEN LPRINT " WORD ------REFERENCES------REFERENCES------REFERENCES------REFERENCES------" 8920 ON ERROR GOTO 0 8930 LINECNT=8 8940 RETURN 8950 ' 8960 ' PRINT THE LINE NUMBER THAT IS CURRENTLY PROCESSING 8970 ' 8980 LOCATE 25,29,0 8990 PRINT CURLNUM$; 9000 RETURN 9010 ' 9020 ' SEE WHAT KIND OF ADAPTER IS ON THIS SYSTEM 9030 ' 9040 DEF SEG=0 9050 IBMMONO=0 9060 IF (PEEK(&H410) AND &H30) = &H30 THEN IBMMONO=1 9070 CURSOR.STOP=7 9080 IF IBMMONO=1 THEN CURSOR.STOP=13 9090 LOCATE ,,,0,CURSOR.STOP 9100 RETURN 9110 ' 9120 FOR BEEP1=1 TO BEEPCNT 9130 BEEP 9140 FOR BEEP2=1 TO BEEPLOOP 9150 NEXT BEEP2 9160 NEXT BEEP1 9170 RETURN 9180 ' 9190 COLOR 0,7 9200 CLS 9210 PRINT " ******************************" 9220 PRINT " * BASIC PROGRAM PROCESSOR *" 9230 PRINT " ******************************" 9240 PRINT 9250 PRINT 9260 PRINT " OPTION DESCRIPTION" 9270 PRINT " ------ ---------------------------" 9280 PRINT 9290 PRINT " 1 EXPAND BASIC PROGRAM" 9300 PRINT " 2 LINE NUMBER CROSS REFERENCE" 9310 PRINT " 3 DATA NAME CROSS REFERENCE" 9320 PRINT " 4 RESERVED WORD CROSS REFERENCE" 9330 PRINT " 5 COMPRESS BASIC PROGRAM" 9340 PRINT " 9 EXIT PROGRAM" 9350 PRINT 9360 PRINT 9370 COLOR 31,0 9380 ROW=CSRLIN 9390 COLUMN=POS(0) 9400 GOSUB 9630 9410 GOSUB 9120 9420 GOSUB 9660 9430 KEYIN$=INKEY$ 9440 IF KEYIN$="" GOTO 9430 9450 IF LEN(KEYIN$) <> 1 THEN BEEP:GOTO 9190 9460 COLOR 15,0 9470 PRINT KEYIN$ 9480 IF VAL(KEYIN$) < 1 THEN BEEP:GOTO 9190 9490 IF VAL(KEYIN$)=9 THEN COLOR 7,0:CLS:GOTO 13450 9500 IF VAL(KEYIN$) > 5 THEN BEEP:GOTO 9190 9510 RUNTYPE=VAL(KEYIN$) 9520 ACTUAL.RUNTYPE=RUNTYPE 9530 IF ACTUAL.RUNTYPE=1 THEN GOSUB 9790 9540 IF ACTUAL.RUNTYPE=5 THEN GOSUB 9790 9550 IF LPRNT THEN GOSUB 9730: GOTO 9580 9560 IF ACTUAL.RUNTYPE=1 OR ACTUAL.RUNTYPE=5 GOTO 9580 9570 GOSUB 9730 9580 IF RUNTYPE=5 THEN RUNTYPE=2 9590 ON ERROR GOTO 0 9600 COLOR 7,0 9610 RETURN 9620 ' 9630 PRINT " SELECT AND ENTER OPTION "; 9640 RETURN 9650 ' 9660 DEF SEG=0 9670 POKE 1050,PEEK(1052) ' FLUSH SYSTEM KEYBOARD BUFFER 9680 DEF SEG 9690 IF VER$="C" THEN RETURN 9700 POKE 106,0 ' FLUSH BASIC INTERNAL KEYBOARD BUFFER 9710 RETURN 9720 ' 9730 ON ERROR GOTO 8310 9740 WIDTH "LPT1:",132 9750 LPRINT CHR$(15) 9760 EJECT=TRUE 9770 RETURN 9780 ' 9790 PRINT 9800 PRINT 9810 SROW=ROW 9820 SCOLUMN=COLUMN 9830 ROW=CSRLIN 9840 COLUMN=POS(0) 9850 LOCATE SROW,SCOLUMN 9860 COLOR 15,0 9870 GOSUB 9630 9880 COLOR 0,7 9890 LOCATE ROW,COLUMN,0 9900 PRINT STRING$(79," "); 9910 LOCATE ROW,COLUMN,1 9920 COLOR 31,0 9930 PRINT "DO YOU WANT "; 9940 IF ACTUAL.RUNTYPE=1 THEN PRINT "AN EXPANDED "; 9950 IF ACTUAL.RUNTYPE=5 THEN PRINT "A COMPRESSED "; 9960 PRINT "PROGRAM LISTING ALSO? (Y OR N) > "; 9970 GOSUB 9660 9980 ANS$=INKEY$ 9990 IF ANS$="" GOTO 9980 10000 IF LEN(ANS$)<>1 THEN BEEP:GOTO 9980 10010 IF ANS$=CHR$(27) GOTO 13450 10020 COLOR 8,0 10030 PRINT ANS$; 10040 COLOR 0,7 10050 IF ANS$="N" THEN RETURN 10060 IF ANS$<>"Y" THEN BEEP:GOTO 9890 10070 LPRNT=TRUE 10080 RETURN 10090 ' 10100 ROW=CSRLIN 10110 COLUMN=POS(0) 10120 LOCATE ROW,COLUMN,0 10130 FOR I=1 TO 24 - ROW 10140 PRINT STRING$(79," ") 10150 NEXT 10160 OUTDRIVE$="" 10170 LOCATE ROW,COLUMN,1 10180 BEEP 10190 PRINT "CREATING OUTPUT FILE : "+OUTFILE$+" WHILE "+REASON$ 10200 PRINT 10210 PRINT "WHAT DRIVE IS THE FILE TO BE ON (A OR B OR ENTER FOR DEFAULT)" 10220 PRINT "DRIVE : "; 10230 GOSUB 9660 10240 OUTDRIVE$=INKEY$ 10250 IF OUTDRIVE$="" GOTO 10240 10260 IF OUTDRIVE$=CHR$(27) GOTO 13450 10270 IF LEN(OUTDRIVE$)<>1 THEN BEEP:GOTO 10240 10280 IF OUTDRIVE$=CR$ THEN OUTDRIVE$="":GOTO 10340 10290 PRINT OUTDRIVE$; 10300 IF OUTDRIVE$="A" GOTO 10340 10310 IF OUTDRIVE$="B" GOTO 10340 10320 GOTO 10120 10330 ' 10340 ON ERROR GOTO 10390 10350 OPEN OUTDRIVE$+":"+OUTFILE$ FOR OUTPUT AS #2 10360 ON ERROR GOTO 0 10370 RETURN 10380 ' 10390 ROW=CSRLIN 10400 COLUMN=POS(0) 10410 GOSUB 4600 10420 RESUME 10430 10430 ON ERROR GOTO 0 10440 LOCATE 24,1,1 10450 COLOR 15 10460 PRINT REASON$;" FILE OPEN ON ";OUTFILE$;" FAILED. ";M$ 10470 M$=" " 10480 PRINT "CORRECT PROBLEM AND PRESS ANY KEY TO CONTINUE"; 10490 GOSUB 9660 10500 KEYIN$=INKEY$ 10510 IF KEYIN$="" GOTO 10500 10520 IF KEYIN$=CHR$(27) GOTO 13450 10530 CLS 10540 LOCATE ROW,COLUMN,0 10550 GOTO 10120 10560 ' 10570 ' 10580 ' SET CAPSLOCK ON 10590 ' 10600 DEF SEG=&H40 10610 POKE &H17,PEEK(&H17) OR 64 10620 DEF SEG 10630 RETURN 10640 ' 10650 '************************************************************************* 10660 '* * 10670 '* LOGIC TO COMPRESS A BASIC PROGRAM * 10680 '* * 10690 '************************************************************************* 10700 FREECNT=0 10710 FREE!=FRE("") 10720 S$="" 10730 X=1 10740 ON ERROR GOTO 0 10750 CLOSE 10760 OPEN DSN$ FOR INPUT AS 1 10770 OUTFILE$="TEMPCOMP.BAS" 10780 REASON$="COMPRESSING PROGRAM" 10790 GOSUB 10100 10800 START$=TIME$ 10810 LOCATE 25,1,0 10820 PRINT "PROCESSING LINE NUMBER = "; 10830 IF EOF(1) GOTO 12640 10840 FREECNT=FREECNT + 1 10850 IF FREECNT > FREELMT THEN FREECNT=0:FREE!=FRE("") 10860 GOSUB 1920 10870 GOSUB 13000 10880 L=LEN(B$) 10890 GOSUB 4070 10900 E=BEND 10910 GOSUB 10960 10920 GOTO 11350 10930 ' 10940 ' ISOLATE LINE NUMBER AND FIND START OF BASIC STATEMENT(S) 10950 ' 10960 CURLNUM$="" 10970 FOR I = 1 TO E 10980 C$=MID$(B$,I,1) 10990 IF C$>BLANK$ GOTO 11010 11000 NEXT I 11010 S=I 11020 P$="" 11030 FOR I = S TO E 11040 C$=MID$(B$,I,1) 11050 IF C$<"0" GOTO 11090 11060 IF C$>"9" GOTO 11090 11070 P$=P$ + C$ 11080 NEXT I 11090 IF I=E THEN ERRNO=1:GOTO 4260 11100 IF LEN(P$)<1 THEN ERRN0=1:GOTO 4260 11110 IF LEN(P$)>5 THEN ERRNO=1:GOTO 4260 11120 CURLNUM$=P$ 11130 LOCATE 25,29,0 11140 PRINT CURLNUM$; 11150 CURLINE!=VAL(CURLNUM$) 11160 LINENO=(CURLINE! - 32767) 11170 S=I 11180 GOSUB 11280 11190 FOR I=S TO E 11200 C$=MID$(B$,I,1) 11210 IF C$>BLANK$ GOTO 11240 11220 NEXT I 11230 IF I=E THEN ERRNO=2:GOTO 4260 11240 S=I 11250 P$=MID$(B$,S) 11260 RETURN 11270 ' 11280 EQUAL.LINENOS=FALSE 11290 FOR X=X TO NUMLINES 11300 IF LINENO=LINENOS(X,1) THEN EQUAL.LINENOS=TRUE:RETURN 11310 IF LINENO<LINENOS(X,1) THEN RETURN 11320 NEXT X 11330 RETURN 11340 ' 11350 ADD=FALSE 11360 REMPOS=0 11370 IFPOS=0 11380 IF EQUAL.LINENOS GOTO 12710 11390 ADD=TRUE 11400 IF MID$(P$,1,1) = "'" GOTO 10830 11410 IF MID$(P$,1,3) = "REM" GOTO 11530 11420 IF MID$(P$,1,4) = "DATA" GOTO 11610 11430 GOSUB 12020 11440 IF ADD=FALSE THEN GOSUB 11730 11450 IF S$="" THEN S$=CURLNUM$+" "+P$:GOTO 11500 11460 IF LEN(S$)>253 THEN ADD=FALSE:GOTO 11440 11470 TOTAL.LEN=LEN(S$)+LEN(P$) + 1 11480 IF TOTAL.LEN > 253 THEN ADD=FALSE:GOTO 11440 11490 S$=S$+":"+P$ 11500 IF IFPOS <> 0 THEN GOSUB 11730 11510 GOTO 10830 11520 ' 11530 IF LEN(P$)<4 GOTO 10830 11540 IF MID$(P$,4,1)=" " GOTO 10830 11550 IF MID$(P$,4,1)="." GOTO 11430 11560 IF ASC(MID$(P$,4,1))<48 GOTO 10830 11570 IF ASC(MID$(P$,4,1))>90 GOTO 10830 11580 IF (ASC(MID$(P$,4,1))>57) AND (ASC(MID$(P$,4,1))<65) GOTO 10830 11590 GOTO 11430 11600 ' 11610 IF LEN(P$)<5 GOTO 10830 11620 IF MID$(P$,5,1)=" " GOTO 11690 11630 IF MID$(P$,5,1)="." GOTO 11430 11640 IF ASC(MID$(P$,5,1))<48 GOTO 11690 11650 IF ASC(MID$(P$,5,1))>90 GOTO 11690 11660 IF (ASC(MID$(P$,5,1))>57) AND (ASC(MID$(P$,5,1))<65) GOTO 11690 11670 GOTO 11430 11680 ' 11690 IFPOS=1 11700 ADD=FALSE 11710 GOTO 11440 11720 ' 11730 IF S$="" THEN RETURN 11740 GOSUB 11780 11750 S$="" 11760 RETURN 11770 ' 11780 ON ERROR GOTO 11840 11790 PRINT#2,S$ 11800 ON ERROR GOTO 0 11810 IF LPRNT THEN LPRINT S$ 11820 RETURN 11830 ' 11840 ROW=CSRLIN 11850 COLUMN=POS(0) 11860 GOSUB 4600 11870 RESUME 11880 11880 ON ERROR GOTO 0 11890 LOCATE 24,1,1 11900 COLOR 15 11910 PRINT "COMPRESSED PROGRAM WRITE FAILED. ";M$ 11920 M$=" " 11930 PRINT "CORRECT PROBLEM AND PRESS ANY KEY TO CONTINUE" 11940 GOSUB 9660 11950 KEYIN$=INKEY$ 11960 IF KEYIN$="" GOTO 11950 11970 IF KEYIN$=CHR$(27) GOTO 13450 11980 COLOR 7 11990 LOCATE ROW,COLUMN,0 12000 GOTO 11780 12010 ' 12020 I=1 12030 H$=P$ 12040 FOR I=I TO LEN(P$) 12050 IF MID$(P$,I,1)=QUOTE$ GOTO 12100 12060 IF MID$(P$,I,1)=APOST$ GOTO 12200 12070 NEXT I 12080 GOTO 12310 12090 ' 12100 MID$(H$,I,1)=BLANK$ 12110 I=I + 1 12120 FOR I=I TO LEN(P$) 12130 MID$(H$,I,1)=BLANK$ 12140 IF MID$(P$,I,1)=QUOTE$ THEN I=I + 1:GOTO 12040 12150 NEXT I 12160 PRINT:PRINT "PROGRAM TRAP REACHED" 12170 STOP 12180 END 12190 ' 12200 P$=MID$(P$,1,I - 1) 12210 L=LEN(P$) 12220 FOR I=L TO 1 STEP -1 12230 IF MID$(P$,I,1)<>BLANK$ GOTO 12280 12240 NEXT I 12250 ERRNO=3 12260 GOTO 4260 12270 ' 12280 P$=MID$(P$,1,I) 12290 H$=MID$(H$,1,I) 12300 L=LEN(P$) 12310 GOSUB 12370 12320 IFPOS=INSTR(1,H$,"IF ") 12330 REMPOS=INSTR(1,H$,"REM ") 12340 IF REMPOS<>0 THEN GOSUB 12500 12350 RETURN 12360 ' 12370 FOR I=1 TO LEN(H$) 12380 V=ASC(MID$(H$,I,1)) 12390 IF V=46 GOTO 12440 12400 IF V<48 GOTO 12470 12410 IF V>90 GOTO 12470 12420 IF V>64 GOTO 12440 12430 IF V>57 GOTO 12470 12440 NEXT I 12450 RETURN 12460 ' 12470 MID$(H$,I,1)=BLANK$ 12480 GOTO 12440 12490 ' 12500 P$=MID$(P$,1,REMPOS - 1) 12510 H$=MID$(H$,1,REMPOS - 1) 12520 L=LEN(P$) 12530 FOR I=L TO 1 STEP -1 12540 IF MID$(P$,I,1)<>BLANK$ THEN 12590 12550 NEXT I 12560 ERRNO=3 12570 GOTO 4260 12580 ' 12590 P$=MID$(P$,1,I) 12600 H$=MID$(H$,1,I) 12610 L=LEN(P$) 12620 RETURN 12630 ' 12640 GOSUB 11730 12650 FINISH$=TIME$ 12660 PRINT 12670 PRINT "COMPRESS PROCESSING FINISHED AT : ";FINISH$ 12680 PRINT "COMPRESS PROCESSING STARTED AT : ";START$ 12690 GOTO 13450 12700 ' 12710 IF MID$(P$,1,1)="'" THEN IFPOS=1:GOTO 11440 12720 IF MID$(P$,1,3)="REM" GOTO 12760 12730 IF MID$(P$,1,4)="DATA" GOTO 12880 12740 GOTO 11430 12750 ' 12760 IF LEN(P$)<4 GOTO 12840 12770 IF MID$(P$,4,1)="." GOTO 11430 12780 IF MID$(P$,4,1)=" " GOTO 12840 12790 IF ASC(MID$(P$,4,1))<48 GOTO 12840 12800 IF ASC(MID$(P$,4,1))>90 GOTO 12840 12810 IF (ASC(MID$(P$,4,1))>57) AND (ASC(MID$(P$,4,1))<65) GOTO 12840 12820 GOTO 11430 12830 ' 12840 ADD=FALSE 12850 IFPOS=1 12860 GOTO 11440 12870 ' 12880 IF LEN(P$)<5 GOTO 12960 12890 IF MID$(P$,5,1)="." GOTO 11430 12900 IF MID$(P$,5,1)=" " GOTO 12960 12910 IF ASC(MID$(P$,5,1))<48 GOTO 12960 12920 IF ASC(MID$(P$,5,1))>90 GOTO 12960 12930 IF (ASC(MID$(P$,5,1))>57) AND (ASC(MID$(P$,5,1))<65) GOTO 12960 12940 GOTO 11430 12950 ' 12960 ADD=FALSE 12970 IFPOS=1 12980 GOTO 11440 12990 ' 13000 I=1 13010 FOR I=I TO LEN(B$) 13020 C$=MID$(B$,I,1) 13030 IF C$=APOST$ THEN RETURN 13040 IF C$=QUOTE$ GOTO 13230 13050 IF I>1 THEN IF C$=":" AND MID$(B$,I-1,1)=":" THEN MID$(B$,I,1)=BLANK$ 13060 IF C$<BLANK$ THEN MID$(B$,I,1)=BLANK$ 13070 IF C$>CHR$(122) THEN MID$(B$,I,1)=BLANK$ 13080 IF C$=BLANK$ GOTO 13310 13090 IF C$>CHR$(96) THEN MID$(B$,I,1)=CHR$(ASC(C$) AND 95) 13100 IF (C$<>"D") AND (C$<>"R") GOTO 13200 13110 IF C$<>"R" GOTO 13170 13120 C$=MID$(B$,I,4) 13130 GOSUB 3770 13140 IF C$=REM1$ THEN RETURN 13150 GOTO 13200 13160 ' 13170 C$=MID$(B$,I,5) 13180 GOSUB 3910 13190 IF C$=DATA1$ THEN RETURN 13200 NEXT I 13210 RETURN 13220 ' 13230 FOR I=I+1 TO LEN(B$) 13240 IF MID$(B$,I,1)=QUOTE$ THEN I=I+1:GOTO 13010 13250 NEXT I 13260 IF LEN(B$)>253 THEN ERRNO=5:GOTO 4260 13270 B$=B$+QUOTE$ 13280 L=LEN(B$) 13290 RETURN 13300 ' 13310 IF I>=LEN(B$) THEN RETURN 13320 SB$=MID$(B$,1,I) 13330 FOR J=I+1 TO LEN(B$) 13340 IF MID$(B$,J,1)<>BLANK$ GOTO 13360 13350 NEXT J 13360 C$=MID$(SB$,LEN(SB$)-1,1) 13370 IF INSTR("=:,(<>*/\;^",C$)<>0 THEN SB$=LEFT$(SB$,LEN(SB$)-1) 13380 C$=MID$(B$,J,1) 13390 IF RIGHT$(SB$,1)= BLANK$ THEN IF INSTR("=:,)<>*/\^;",C$)<>0 THEN SB$=LEFT$(SB$,LEN(SB$)-1) 13400 I=LEN(SB$)+1 13410 SB$=SB$+MID$(B$,J) 13420 B$=SB$ 13430 GOTO 13010 13440 ' 13450 ON ERROR GOTO 0 13460 CLOSE 13470 PRINT 13480 BEEP 13490 KEYIN$="" 13500 PRINT "PRESS ENTER TO EXIT PROGRAM" 13510 GOSUB 9660 13520 KEYIN$=INKEY$ 13530 IF KEYIN$="" GOTO 13520 13540 IF LEN(KEYIN$)<>1 GOTO 13520 13550 IF KEYIN$<>CR$ GOTO 13520 13560 CLEAR 13570 COLOR 7,0 13580 CLS 13590 END 13600 GOTO 13450 13610 ' 13620 DATA 153 13630 DATA "ABS",2 13640 DATA "AND",1 13650 DATA "ASC",3 13660 DATA "ATN",2 13670 DATA "AUTO",9 13680 DATA "BEEP",1 13690 DATA "BLOAD",9 13700 DATA "BSAVE",9 13710 DATA "CALL",4 13720 DATA "CDBL",1 13730 DATA "CHAIN",4 13740 DATA "CHR",3 13750 DATA "CINT",1 13760 DATA "CIRCLE",1 13770 DATA "CLEAR",1 13780 DATA "CLOSE",1 13790 DATA "CLS",1 13800 DATA "COLOR",1 13810 DATA "COM",1 13820 DATA "COMMON",4 13830 DATA "CONT",9 13840 DATA "COS",2 13850 DATA "CSNG",1 13860 DATA "CSRLIN",1 13870 DATA "CVD",1 13880 DATA "CVI",1 13890 DATA "CVS",1 13900 DATA "DATA",0 13910 DATA "DATE",1 13920 DATA "DEF",1 13930 DATA "DEFDBL",1 13940 DATA "DEFINT",1 13950 DATA "DEFSNG",1 13960 DATA "DEFSTR",1 13970 DATA "DELETE",9 13980 DATA "DIM",1 13990 DATA "DRAW",1 14000 DATA "EDIT",9 14010 DATA "ELSE",0 14020 DATA "END",1 14030 DATA "EOF",1 14040 DATA "EQV",1 14050 DATA "ERASE",1 14060 DATA "ERL",1 14070 DATA "ERR",1 14080 DATA "ERROR",1 14090 DATA "EXP",2 14100 DATA "FIELD",1 14110 DATA "FILES",9 14120 DATA "FIX",1 14130 DATA "FOR",4 14140 DATA "FRE",1 14150 DATA "GET",1 14160 DATA "GOSUB",4 14170 DATA "GOTO",4 14180 DATA "HEX",3 14190 DATA "IF",1 14200 DATA "IMP",1 14210 DATA "INKEY",1 14220 DATA "INP",1 14230 DATA "INPUT",1 14240 DATA "INSTR",4 14250 DATA "INT",2 14260 DATA "KEY",1 14270 DATA "KILL",9 14280 DATA "LEFT",3 14290 DATA "LEN",3 14300 DATA "LET",0 14310 DATA "LINE",1 14320 DATA "LIST",9 14330 DATA "LLIST",9 14340 DATA "LOAD",9 14350 DATA "LOC",1 14360 DATA "LOCATE",1 14370 DATA "LOF",1 14380 DATA "LOG",2 14390 DATA "LPOS",1 14400 DATA "LPRINT",1 14410 DATA "LSET",1 14420 DATA "MERGE",9 14430 DATA "MID",3 14440 DATA "MKD",3 14450 DATA "MKI",3 14460 DATA "MKS",3 14470 DATA "MOD",2 14480 DATA "MOTOR",1 14490 DATA "NAME",9 14500 DATA "NEW",9 14510 DATA "NEXT",4 14520 DATA "NOT",0 14530 DATA "OCT",3 14540 DATA "OFF",1 14550 DATA "ON",0 14560 DATA "OPEN",1 14570 DATA "OPTION",1 14580 DATA "OR",0 14590 DATA "OUT",1 14600 DATA "PAINT",1 14610 DATA "PEEK",1 14620 DATA "PEN",1 14630 DATA "PLAY",1 14640 DATA "POINT",1 14650 DATA "POKE",1 14660 DATA "POS",1 14670 DATA "PRESET",1 14680 DATA "PRINT",1 14690 DATA "PSET",1 14700 DATA "PUT",1 14710 DATA "RANDOMIZE",2 14720 DATA "READ",1 14730 DATA "REM",1 14740 DATA "RENUM",9 14750 DATA "RESET",1 14760 DATA "RESTORE",1 14770 DATA "RESUME",4 14780 DATA "RETURN",4 14790 DATA "RIGHT",3 14800 DATA "RND",2 14810 DATA "RSET",1 14820 DATA "RUN",1 14830 DATA "SAVE",9 14840 DATA "SCREEN",1 14850 DATA "SGN",2 14860 DATA "SIN",2 14870 DATA "SOUND",1 14880 DATA "SPACE",3 14890 DATA "SPC",3 14900 DATA "SQR",2 14910 DATA "STEP",0 14920 DATA "STICK",1 14930 DATA "STOP",1 14940 DATA "STR",3 14950 DATA "STRIG",1 14960 DATA "STRING",1 14970 DATA "SWAP",1 14980 DATA "SYSTEM",9 14990 DATA "TAB",0 15000 DATA "TAN",2 15010 DATA "THEN",0 15020 DATA "TIME",1 15030 DATA "TO",0 15040 DATA "TROFF",1 15050 DATA "TRON",1 15060 DATA "USING",1 15070 DATA "USR",4 15080 DATA "VAL",3 15090 DATA "VARPTR",1 15100 DATA "WAIT",1 15110 DATA "WEND",1 15120 DATA "WHILE",1 15130 DATA "WIDTH",1 15140 DATA "WRITE",1 15150 DATA "XOR",0 15160 END