Listing of file='PASCAL.BAS;01' on disk='vmedia/tiny_pascal-sector.ccvf'
0 REM
10 CLEAR 5000:PLOT 6,7,15,27,11,12
15 PRINT TAB( 15)"PASCAL SUBSET COMPILER"
17 PRINT TAB( 15)"eeeeeeeeeeeeeeeeeeeeee"
20 PRINT :PRINT TAB( 30)"FROM BYTE MAGAZINE (KIN-MAN CHUNG)"
30 PRINT :PRINT :REM COMPUCOLOR VERSION BY T G PRICE 8/80
40 N0= 32:REM # OF RESERVED WORDS
50 T0= 50:REM SYM TABLE SIZE
60 N1= 32767:REM LARGEST INT
70 N2= 8:REM IDENT LEN
80 DIM W0$(N0):REM RESERVED WORDS
90 DIM T$(T0):REM SYMBOL TABLE
100 DIM T0$(T0):REM KIND OF IDENT IN SYM TABLE : C,V,P
110 REM L$ IS LINE BUFFER OF MAX LEN 64
120 REM A$ OF LEN N2 IS IDENT:B$ OF LEN 5 IS RESERVED WORD
130 DIM S(100),S$(100):REM STACKS
140 DIM T1(T0):REM LEVEL OF ID IN SYM TABLE
150 DIM T2(T0):REM VAL FOR CONST OR ADR FOR INT OF ID IN S T
160 DIM T3(T0):REM ARRAY DIM OR # OF PROC PARAMETERS
170 W0$(1)= "AND":W0$(2)= "ARRAY":W0$(3)= "BEGIN"
173 W0$(4)= "CALL":W0$(5)= "CASE":W0$(6)= "CONST"
176 W0$(7)= "DIV":W0$(8)= "DO":W0$(9)= "DOWNT"
179 W0$(10)= "ELSE":W0$(11)= "END":W0$(12)= "FOR"
182 W0$(13)= "FUNC":W0$(14)= "IF":W0$(15)= "INTEG"
185 W0$(16)= "MEM":W0$(17)= "MOD":W0$(18)= "NOT"
188 W0$(19)= "OF":W0$(20)= "OR":W0$(21)= "PROC"
191 W0$(22)= "SHL":W0$(23)= "SHR":W0$(24)= "THEN"
194 W0$(25)= "TO":W0$(26)= "TYPE":W0$(27)= "UNTIL"
197 W0$(28)= "VAR":W0$(29)= "WHILE":W0$(30)= "WRITE"
198 W0$(31)= "READ":W0$(32)= "REPEA"
200 REM SPACE FILLER
210 DIM M$(9),C$(80)
220 M$(1)= "LIT":M$(2)= "OPR":M$(3)= "LOD"
223 M$(4)= "STO":M$(5)= "CAL":M$(6)= "INT"
227 M$(7)= "JMP":M$(8)= "JPC":M$(9)= "CSP"
229 REM P-CODE MNEMONICS
230 P8= 1
240 INPUT "ENTER P-CODE START ADDRESS:";P7:PRINT ""
245 P9= P7
250 PRINT :PRINT TAB( 25)"PCODE STARTS AT";P7
260 Q9= 65535:REM LAST USABLE MEM
280 PRINT :INPUT "DO YOU WISH THE P-CODES DISPLAYED ?";Y$
290 Y9= 1:IF Y$= "Y"THEN Y9= 0
295 PRINT :INPUT "PASCAL SOURCE FILE >";L$
296 INPUT "HOW MANY BLOCKS";SZ
297 FILE "R",3,L$+ ".P",1;1,128* SZ,1
298 C0= 1:L$= ""
300 X$= " ":GOSUB 1240:REM GET A TOKEN
310 GOSUB 5340:REM BLOCK
320 K$= ".":E= 9:GOSUB 420:REM ERROR CHECK
330 POKE P9,255:POKE P9+ 1,255:REM POKE IN EOF MARKER
340 PRINT :PRINT :PRINT "COMPILATION COMPLETE."
350 FILE "C",3:PRINT "P-CODE STARTS AT"P7" : ENDS AT"P9
360 END
390 REM ****************
400 REM ERROR ROUTINES
410 REM ****************
420 REM ERROR CHECK FOR CURRENT TOKEN
430 IF S0$= K$THEN RETURN
450 E9= E
470 GOSUB 610
480 PRINT "FATAL ERROR - COMPILATION TERMINATED":END
500 REM ****************
510 REM ERROR CHECK FOR NEXT TOKEN
520 GOSUB 1240
530 IF S0$= K$THEN RETURN
550 E9= E
570 GOSUB 610
580 PRINT "FATAL ERROR - COMPILATION TERMINATED":END
600 REM ****************
610 REM ERROR MESSAGES
615 PRINT "ERROR #"E9" DETECTED - ";
620 ON INT ((E9+ 4)/ 5)GOTO 630,640,650,660,670,680,690,700
630 ON E9GOTO 710,720,730,740,750
640 ON E9- 5GOTO 990,990,990,760,770
650 ON E9- 10GOTO 780,790,800,990,990
660 ON E9- 15GOTO 810,820,830,840,850
670 ON E9- 20GOTO 860,870,880,990,890
680 ON E9- 25GOTO 900,910,920,990,930
690 ON E9- 30GOTO 940,990,950,960,970
700 ON E9- 35GOTO 980
710 PRINT "MEM FULL":RETURN
720 PRINT "CONST EXPECTED":RETURN
730 PRINT "'=' EXPECTED":RETURN
740 PRINT "IDENTIFIER EXPECTED":RETURN
750 PRINT "';' OR ':' MISSING":RETURN
760 PRINT "'.' EXPECTED":RETURN
770 PRINT "';' MISSING":RETURN
780 PRINT "UNDECLARED IDENT":RETURN
790 PRINT "ILLEGAL IDENT":RETURN
800 PRINT "':=' EXPECTED":RETURN
810 PRINT "'THEN' EXPECTED":RETURN
820 PRINT "';' OR 'END' EXPECTED":RETURN
830 PRINT "'DO' EXPECTED":RETURN
840 PRINT "INCORRECT SYMBOL":RETURN
850 PRINT "RELATIONAL OPERATOR EXPECTED":RETURN
860 PRINT "USE OF PROC IDENT IN EXPR":RETURN
870 PRINT "')' EXPECTED":RETURN
880 PRINT "ILLEGAL FACTOR":RETURN
890 PRINT "'BEGIN' EXPECTED":RETURN
900 PRINT "'OF' EXPECTED":RETURN
910 PRINT "ILLEGAL HEX CONST":RETURN
920 PRINT "'TO' OR 'DOWNTO' EXPECTED":RETURN
930 PRINT "NUMBER OUT OF RANGE":RETURN
940 PRINT "'(' EXPECTED":RETURN
950 PRINT "'[' EXPECTED":RETURN
960 PRINT "']' EXPECTED":RETURN
970 PRINT "PARAMETERS MISMATCHED":RETURN
980 PRINT "DATA TYPE NOT RECOGNISED":RETURN
990 PRINT "BUG":RETURN
1000 REM ****************
1010 REM SCANNER
1020 REM ****************
1030 REM GETCHAR
1040 GET 3,1,C0;X$[1]:C0= C0+ 1
1050 IF X$= CHR$ (13)THEN PRINT L$:L$= "":C0= C0+ 1:GOTO 1040
1060 L$= L$+ X$
1170 RETURN
1230 REM ****************
1240 REM GET A TOKEN
1250 REM RETURN S0$=TOKEN, A$=STRING, N3=NUMERIC
1260 IF X$< > " "AND X$< > CHR$ (9)THEN 1275
1270 GOSUB 1030:GOTO 1260:REM FLUSH BLANKS
1275 IF X$= "."THEN S0$= X$:RETURN
1280 IF X$< "A"THEN 1460:REM IDENTIFIER?
1290 IF X$> "Z"THEN 1460
1300 K= 0:A$= ""
1310 IF K> = N2THEN 1330:REM ONLY FIRST N2 LETTERS USED
1320 K= K+ 1:A$= A$+ X$
1330 GOSUB 1030
1340 T= ASC (X$)
1350 IF T> 47AND T< 58OR T> 64AND T< 91THEN 1310:REM D OR L
1360 REM SEARCH FOR RESERVED WORDS
1370 B$= LEFT$ (A$,5)
1380 FOR I= 1TO N0
1390 IF B$= W0$(I)THEN S0$= B$:RETURN
1400 NEXT I
1410 S0$= "IDENT":RETURN
1460 Z$= ""
1470 IF X$< "0"OR X$> "9"THEN 1580:REM AN INTEGER?
1490 S0$= "NUM"
1500 Z$= Z$+ X$
1510 GOSUB 1030
1520 IF ASC (X$)> = 48AND ASC (X$)< = 57THEN 1500
1530 N3= VAL (Z$)
1540 IF N3< = N1THEN RETURN
1550 E= 30:GOSUB 550
1560 N3= N1:RETURN
1570 REM CHECK FOR SPECIAL SYMBOL
1580 IF X$< > ":"THEN 1640
1590 GOSUB 1030
1600 IF X$= "="THEN 1620
1610 S0$= ":":RETURN
1620 S0$= ":="
1630 GOSUB 1030:RETURN
1640 IF X$< > "<"THEN 1710
1650 GOSUB 1030
1660 IF X$= ">"THEN 1690
1670 IF X$= "="THEN 1700
1680 S0$= "<":RETURN
1690 S0$= "<>":GOSUB 1030:RETURN
1700 S0$= "<=":GOSUB 1030:RETURN
1710 IF X$< > ">"THEN 1750
1720 GOSUB 1030:S0$= ">"
1730 IF X$< > "="THEN RETURN
1740 S0$= ">=":GOSUB 1030:RETURN
1750 IF X$< > "'"THEN 1790
1760 S0$= "STR":C$= ""
1770 GOSUB 1030:IF X$= "'"THEN GOSUB 1030:RETURN
1780 C$= C$+ X$:GOTO 1770
1790 IF X$< > "!"THEN 1820:REM IGNORE COMMENTS
1800 GOSUB 1030:IF X$< > "!"THEN 1800
1810 GOSUB 1030:GOTO 1240
1820 IF X$< > "%"THEN 1930:REM HEX CONSTANT
1830 GOSUB 1030:S0$= "NUM":N3= 0
1840 FOR I= 1TO 4
1850 T= ASC (X$)
1860 IF T> = 48AND T< = 57THEN 1880
1870 IF T> = 65AND T< = 70THEN T= T- 7:GOTO 1880
1875 GOTO 1910
1880 T= T- 48
1890 N3= N3* 16+ T:GOSUB 1030:NEXT I
1900 RETURN
1910 IF I> 1THEN E= 27:GOSUB 550
1920 S0$= "%":RETURN
1930 S0$= X$:GOTO 1030
1940 REM ****************
1950 REM ENTER SYMBOL INTO TABLE
1960 T1= T1+ 1
1970 T$(T1)= A$
1980 T0$(T1)= K$:REM STORE TYPE
1990 IF K$< > "C"THEN 2010
2000 T2(T1)= N3:RETURN :REM STORE VALUE
2010 T1(T1)= L1:REM STORE LEVEL OF IDENT
2020 IF K$< > "V"THEN RETURN
2030 IF F9= 0THEN RETURN :REM SP WAS ALLOC FOR PROC PARS
2040 T2(T1)= D0:D0= D0+ 1:RETURN :REM STORE OFFSET
2050 REM ****************
2060 REM FIND IDENT A$ IN T$,STARTING FROM T1 AND UP
2070 REM RETURN POINTER TO TABLE IF FOUND ELSE RETURN 0
2080 FOR I= T1TO 1STEP - 1
2090 IF A$= T$(I)THEN GOTO 2130
2100 NEXT I
2120 I= 0
2130 RETURN
2140 REM ****************
2150 REM PARSER AND CODER
2160 REM ****************
2170 REM CONST DECLARATION
2180 K$= "IDENT":E= 4:GOSUB 420
2190 K$= "=":E= 3:GOSUB 510
2200 GOSUB 1240:GOSUB 2240
2210 K$= "C":GOSUB 1950
2220 GOTO 1240
2230 REM ****************
2240 REM CONSTANT
2250 IF S0$= "NUM"THEN RETURN
2260 IF S0$= "IDENT"THEN 2290:REM CONST?
2270 K$= "STR":E= 2:GOSUB 420
2280 N3= ASC (C$):RETURN :REM TAKE 1ST CHAR
2290 GOSUB 2060:IF I= 0THEN E= 2:GOSUB 550
2300 IF T0$(I)< > "C"THEN E= 2:GOSUB 550
2310 N3= T2(I):RETURN
2320 GOTO 1240
2330 REM ****************
2340 REM VAR DECLARATION
2350 K$= "IDENT":E= 4:GOSUB 420
2360 K$= "V":GOSUB 1950:GOTO 1240
2370 REM ****************
2380 REM SIMPLE EXPRESSION
2390 IF S0$= "+"THEN 2420
2400 IF S0$< > "-"THEN 2590
2410 Y$= S0$:GOSUB 6180
2420 GOSUB 1240
2430 GOSUB 2610
2440 GOSUB 6240
2450 IF Y$= "-"THEN X1= 1:X2= 0:X3= 1:GOSUB 6310
2460 IF S0$= "+"THEN 2500
2470 IF S0$= "-"THEN 2500
2480 IF S0$= "OR"THEN 2500
2490 RETURN
2500 Y$= S0$:GOSUB 6180
2510 GOSUB 1240
2520 GOSUB 2610
2530 GOSUB 6240
2540 IF Y$= "-"THEN 2570
2550 IF Y$= "+"THEN 2580
2560 X1= 1:X2= 0:X3= 14:GOSUB 6310:GOTO 2460
2570 X1= 1:X2= 0:X3= 3:GOSUB 6310:GOTO 2460
2580 X1= 1:X2= 0:X3= 2:GOSUB 6310:GOTO 2460
2590 GOSUB 2610:GOTO 2460
2600 REM ****************
2610 REM TERM
2620 GOSUB 2850
2630 IF S0$= "*"THEN 2700
2640 IF S0$= "DIV"THEN 2700
2650 IF S0$= "AND"THEN 2700
2660 IF S0$= "MOD"THEN 2700
2670 IF S0$= "SHL"THEN 2700
2680 IF S0$= "SHR"THEN 2700
2690 RETURN
2700 Y$= S0$:GOSUB 6180:REM PUSH
2710 GOSUB 1240:GOSUB 2850
2720 GOSUB 6240
2730 IF Y$= "DIV"THEN 2790
2740 IF Y$= "MOD"THEN 2800
2750 IF Y$= "*"THEN 2810
2760 IF Y$= "SHL"THEN 2820
2770 IF Y$= "SHR"THEN 2830
2780 X1= 1:X2= 0:X3= 15:GOSUB 6310:GOTO 2630:REM "AND"
2790 X1= 1:X2= 0:X3= 5:GOSUB 6310:GOTO 2630
2800 X1= 1:X2= 0:X3= 7:GOSUB 6310:GOTO 2630
2810 X1= 1:X2= 0:X3= 4:GOSUB 6310:GOTO 2630
2820 X1= 1:X2= 0:X3= 17:GOSUB 6310:GOTO 2630
2830 X1= 1:X2= 0:X3= 18:GOSUB 6310:GOTO 2630
2840 REM ****************
2850 REM FACTOR
2860 IF S0$= "IDENT"THEN 2940
2870 IF S0$= "NUM"THEN 3060
2880 IF S0$= "STR"THEN 3080
2890 IF S0$= "("THEN 3100
2900 IF S0$= "MEM"THEN 3140
2910 IF S0$= "NOT"THEN 3260
2920 E= 23:GOTO 550
2930 REM *** IDENTIFIER
2940 GOSUB 2060
2950 IF I= 0THEN E= 11:GOTO 550
2960 IF T0$(I)= "P"THEN E= 21:GOTO 550:REM PROC NAME
2970 IF T0$(I)< > "Y"THEN 3000
2980 X1= 5:X2= 0:X3= 1:GOSUB 6310:REM FUNC
2990 I= I- 1:GOTO 4290:REM T2(I)=ADD OF FUNC
3000 IF T0$(I)= "A"THEN 3190:REM ARRAY
3010 IF T0$(I)< > "C"THEN 3030
3020 X1= 0:X2= 0:X3= T2(I):GOSUB 6310
3025 GOTO 1240:REM CONST
3030 X1= 2:X2= L1- T1(I):X3= T2(I):GOSUB 6310:REM ID
3040 GOTO 1240
3050 REM *** NUMERIC CONST
3060 X1= 0:X2= 0:X3= N3:GOSUB 6310:GOTO 1240
3070 REM *** STRING CONST
3080 X1= 0:X2= 0:X3= ASC (C$):GOSUB 6310:GOTO 1240
3090 REM *** PAREN EXPR
3100 GOSUB 1240:GOSUB 3290
3110 IF S0$= ")"THEN 1240
3120 E= 22:GOSUB 550:RETURN
3130 REM *** READ MEMORY
3140 K$= "[":E= 33:GOSUB 510
3150 GOSUB 1240:GOSUB 3290
3160 K$= "]":E= 34:GOSUB 420
3170 GOSUB 1240
3180 X1= 2:X2= 255:X3= 0:GOSUB 6310:RETURN
3190 X= I:GOSUB 6120
3200 K$= "[":E= 33:GOSUB 510
3210 GOSUB 1240:GOSUB 3290
3220 K$= "]":E= 34:GOSUB 420
3230 GOSUB 6150:X1= 18:X2= L1- T1(X):X3= T2(X):GOSUB 6310
3240 GOTO 1240
3250 REM *** NEGATE
3260 GOSUB 1240:GOSUB 2850
3270 X1= 1:X2= 0:X3= 16:GOSUB 6310:RETURN
3280 REM ****************
3290 REM EXPRESSION
3300 GOSUB 2390:REM SIMPLE EXP
3310 IF S0$= "="THEN 3380
3320 IF S0$= "<>"THEN 3380
3330 IF S0$= "<"THEN 3380
3340 IF S0$= "<="THEN 3380
3350 IF S0$= ">"THEN 3380
3360 IF S0$= ">="THEN 3380
3370 RETURN
3380 Y$= S0$:GOSUB 6180:REM PUSH
3390 GOSUB 1240:GOSUB 2390
3400 GOSUB 6240:REM POP
3410 IF Y$= "="THEN X1= 1:X2= 0:X3= 8:GOSUB 6310
3420 IF Y$= "<>"THEN X1= 1:X2= 0:X3= 9:GOSUB 6310
3430 IF Y$= "<"THEN X1= 1:X2= 0:X3= 10:GOSUB 6310
3440 IF Y$= ">="THEN X1= 1:X2= 0:X3= 11:GOSUB 6310
3450 IF Y$= ">"THEN X1= 1:X2= 0:X3= 12:GOSUB 6310
3460 IF Y$= "<="THEN X1= 1:X2= 0:X3= 13:GOSUB 6310
3470 RETURN
3480 REM ****************
3490 REM STATEMENT
3500 IF S0$= "IDENT"THEN 3630
3510 IF S0$= "IF"THEN 4440
3520 IF S0$= "FOR"THEN 5170
3530 IF S0$= "WHILE"THEN 4800
3540 IF S0$= "CASE"THEN 4890
3550 IF S0$= "REPEA"THEN 4730
3560 IF S0$= "BEGIN"THEN 4590
3570 IF S0$= "READ"THEN 4040
3580 IF S0$= "WRITE"THEN 3870
3590 IF S0$= "MEM"THEN 4650
3600 IF S0$= "CALL"THEN 4240
3610 RETURN
3620 REM *** ASSIGNMNT
3630 GOSUB 2060
3640 IF I= 0THEN E= 11:GOSUB 550
3650 IF T0$(I)= "A"THEN 3700:REM ARRAY
3660 IF T0$(I)= "V"THEN 3760:REM INT VAR
3670 IF T0$(I)= "Y"THEN 3760:REM FUNC RETURN VALUE
3680 IF T0$(I)= "P"THEN 4290:REM PROC CALL
3690 E= 12:GOSUB 550
3700 X= I:GOSUB 6120:REM PUSH TBL ADD
3710 X= 16:GOSUB 6120:REM INDEX ADD MODE
3720 K$= "[":E= 33:GOSUB 510
3730 GOSUB 1240:GOSUB 3290
3740 K$= "]":E= 34:GOSUB 420
3750 GOTO 3780
3760 X= I:GOSUB 6120
3770 X= 0:GOSUB 6120
3780 GOSUB 1240
3790 IF S0$= ":="THEN 3810
3800 E= 13:GOSUB 550:GOTO 3820
3810 GOSUB 1240
3820 GOSUB 3290:GOSUB 6150
3830 K= X:GOSUB 6150
3840 X1= 3+ K:X2= L1- T1(X):X3= T2(X):GOSUB 6310
3850 RETURN
3860 REM *** WRITE
3870 K$= "(":E= 31:GOSUB 510
3880 GOSUB 1240:IF S0$< > "STR"THEN 3950
3890 L= LEN (C$):IF L> 1THEN 3910
3900 X1= 0:X2= 0:X3= ASC (C$):GOSUB 6310
3905 X1= 8:X2= 0:X3= 1:GOSUB 6310:GOTO 3940
3910 FOR I= 1TO L
3920 X1= 0:X2= 0:X3= ASC (MID$ (C$,I,1)):GOSUB 6310:NEXT I
3930 X1= 0:X2= 0:X3= L:GOSUB 6310
3935 X1= 8:X2= 0:X3= 8:GOSUB 6310
3940 GOSUB 1240:GOTO 4000
3950 GOSUB 3290:K= 1
3960 IF S0$= "#"THEN K= 3:REM DEC
3970 IF S0$= "%"THEN K= 5:REM HEX
3980 IF K> 1THEN GOSUB 1240
3990 X1= 8:X2= 0:X3= K:GOSUB 6310
4000 IF S0$= ","THEN 3880
4010 K$= ")":E= 22:GOSUB 420
4020 GOTO 1240
4030 REM *** READ
4040 K$= "(":E= 31:GOSUB 510
4050 K$= "IDENT":E= 4:GOSUB 510
4060 GOSUB 2060:IF I= 0THEN E= 11:GOSUB 550
4070 X= I:GOSUB 6120
4080 IF T0$(I)= "A"THEN 4190
4090 IF T0$(I)= "V"THEN L= 0:GOTO 4100
4095 E= 4:GOSUB 550
4100 GOSUB 1240:K= 0
4110 IF S0$= "#"THEN K= 2:REM DEC
4120 IF S0$= "%"THEN K= 4:REM HEX
4130 X1= 8:X2= 0:X3= K:GOSUB 6310
4140 IF K> 0THEN GOSUB 1240
4150 GOSUB 6150:
4155 X1= L+ 3:X2= L1- T1(X):X3= T2(X):GOSUB 6310
4160 IF S0$= ","THEN 4050
4170 K$= ")":E= 31:GOSUB 420
4180 GOTO 1240
4190 K$= "[":E= 33:GOSUB 510
4200 GOSUB 1240:GOSUB 3290
4210 K$= "]":E= 34:GOSUB 420
4220 L= 16:GOTO 4100
4230 REM *** ABSOLUTE MEM CALL
4240 K$= "(":E= 31:GOSUB 510
4250 GOSUB 1240:GOSUB 3290
4260 K$= ")":E= 22:GOSUB 420
4270 X1= 4:X2= 255:X3= 0:GOSUB 6310:GOTO 1240
4280 REM *** PROC OR FUNC CALL
4290 K2= 0:K3= I
4300 IF T3(I)= 0THEN 4400:REM NO PARAMETER
4310 K$= "(":E= 31:GOSUB 510
4320 X= K2:GOSUB 6120
4330 X= K3:GOSUB 6120
4340 GOSUB 1240:GOSUB 3290
4350 GOSUB 6150:K3= X
4360 GOSUB 6150:K2= X:K2= K2+ 1
4370 IF S0$= ","THEN 4320
4380 IF K2< > T3(K3)THEN E= 35:GOSUB 550
4390 K$= ")":E= 22:GOSUB 420
4400 X1= 4:X2= L1- T1(K3):X3= T2(K3):GOSUB 6310
4410 IF K2< > 0THEN X1= 5:X2= 0:X3= - K2:GOSUB 6310
4420 GOTO 1240
4430 REM *** IF
4440 GOSUB 1240
4450 GOSUB 3290
4460 K$= "THEN":E= 16:GOSUB 420
4470 GOSUB 1240
4480 X= C1:GOSUB 6120:REM FORWARD REF POINT
4490 X1= 7:X2= 0:X3= 0:GOSUB 6310:REM JPC
4500 GOSUB 3490
4510 IF S0$< > "ELSE"THEN 6520
4520 GOSUB 6150:K= X
4530 X= C1:GOSUB 6120
4540 X1= 6:X2= 0:X3= 0:GOSUB 6310:REM JMP
4550 X= K:GOSUB 6540:REM FIXUP FORWD REF
4560 GOSUB 1240:GOSUB 3490
4570 GOTO 6520
4580 REM *** COMPOUND STMNT
4590 GOSUB 1240
4600 GOSUB 3490
4610 IF S0$= ";"THEN 4590
4620 IF S0$= "END"THEN 1240:RETURN
4630 E= 17:GOSUB 550:RETURN
4640 REM *** WRITE MEM
4650 K$= "[":E= 33:GOSUB 510
4660 GOSUB 1240:GOSUB 3290
4670 IF S0$< > "]"THEN E= 34:GOSUB 550
4680 K$= ":=":E= 13:GOSUB 510
4690 GOSUB 1240:GOSUB 3290
4700 X1= 3:X2= 255:X3= 0:GOSUB 6310
4710 RETURN
4720 REM *** REPEAT .. UNTIL
4730 X= C1:GOSUB 6120
4740 GOSUB 1240:GOSUB 3490
4750 IF S0$= ";"THEN 4740
4760 K$= "UNTIL":E= 10:GOSUB 420
4770 GOSUB 1240:GOSUB 3290
4780 GOSUB 6150:X1= 7:X2= 0:X3= X:GOSUB 6310
4785 RETURN
4790 REM *** WHILE .. DO
4800 GOSUB 1240:X= C1:GOSUB 6120
4810 GOSUB 3290:X= C1:GOSUB 6120
4820 X1= 7:X2= 0:X3= 0:GOSUB 6310
4830 K$= "DO":E= 18:GOSUB 420
4840 GOSUB 1240:GOSUB 3490
4850 GOSUB 6150:K= X:GOSUB 6150
4860 X1= 6:X2= 0:X3= X:GOSUB 6310
4870 X= K:GOTO 6540
4880 REM *** CASE .. OF
4890 GOSUB 1240:GOSUB 3290
4900 K$= "OF":E= 25:GOSUB 420
4910 I2= 1:REM # OF CASE STATEMENTS
4920 I1= 0:REM # OF CASE LABELS
4930 GOSUB 1240:GOSUB 2240
4940 X1= 1:X2= 0:X3= 21:GOSUB 6310
4941 X1= 0:X2= 0:X3= N3:GOSUB 6310
4942 X1= 1:X2= 0:X3= 8:GOSUB 6310
4950 GOSUB 1240:IF S0$= ":"THEN 4990
4960 K$= ",":E= 5:GOSUB 420
4970 X= C1:GOSUB 6120:X1= 7:X2= 1:X3= 0
4975 GOSUB 6310:REM A MATCH FOUND?
4980 I1= I1+ 1:GOTO 4930
4990 K= C1:X1= 7:X2= 0:X3= 0:
4995 GOSUB 6310:REM GO TO NEXT CASE STMNT IF NO MATCH
4997 IF I1= 0THEN 5010
5000 FOR I= 1TO I1:GOSUB 6520
5005 NEXT I:REM FIXUP FRWRD REFS
5010 X= K:GOSUB 6120
5020 GOSUB 1240:X= I2:GOSUB 6120
5030 GOSUB 3490:GOSUB 6150:I2= X
5040 IF S0$= "ELSE"THEN 5090
5050 IF S0$< > ";"THEN 5130
5060 K= C1:X1= 6:X2= 0:X3= 0
5065 GOSUB 6310:REM EXIT AFTER A CASE STMNT
5070 GOSUB 6520
5080 X= K:GOSUB 6120:I2= I2+ 1:GOTO 4920
5090 K= C1:X1= 6:X2= 0:X3= 0
5095 GOSUB 6310:GOSUB 6520
5100 X= K:GOSUB 6120
5110 GOSUB 1240:X= I2:GOSUB 6120
5120 GOSUB 3490:GOSUB 6150:I2= X
5130 K$= "END":E= 17:GOSUB 420
5140 FOR I= 1TO I2:GOSUB 6520
5145 NEXT I:REM FIXUP FORWD REFS
5150 X1= 5:X2= 0:X3= - 1:GOSUB 6310
5155 GOTO 1240:REM POP VAL OF CASE EXPR
5160 REM *** FOR
5170 K$= "IDENT":E= 4:GOSUB 510
5180 GOSUB 3630:GOSUB 6120
5190 F9= 1:IF S0$= "TO"THEN 5210:REM REMEMBER UP OR DOWN
5200 K$= "DOWNT":E= 28:GOSUB 420:F9= 0
5210 GOSUB 1240:GOSUB 3290
5220 GOSUB 6150:K= X:X= C1:GOSUB 6120
5230 X1= 1:X2= 0:X3= 21:GOSUB 6310
5235 X1= 2:X2= L1- T1(K):X3= T2(K):GOSUB 6310
5240 X1= 1:X2= 0:X3= 13- F9- F9:GOSUB 6310
5245 X= C1:GOSUB 6120
5246 X1= 7:X2= 0:X3= 0:GOSUB 6310
5250 X= F9:GOSUB 6120:X= K:GOSUB 6120
5260 K$= "DO":E= 18:GOSUB 420:GOSUB 1240
5270 GOSUB 3490:GOSUB 6150
5275 X1= 2:X2= L1- T1(X):X3= T2(X):GOSUB 6310
5280 K= X:GOSUB 6150
5285 X1= 1:X2= 0:X3= 20- X:GOSUB 6310
5290 X1= 3:X2= L1- T1(K):X3= T2(K):GOSUB 6310
5300 GOSUB 6150:K= X:GOSUB 6150
5305 X1= 6:X2= 0:X3= X:GOSUB 6310
5310 X= K:GOSUB 6540
5320 X1= 5:X2= 0:X3= - 1:GOSUB 6310
5325 RETURN :REM POP OFF VAL OF LOOP CNTRL VAR
5330 REM ****************
5340 REM BLOCK
5350 D0= 3:REM RSRVD FOR STATIC LINK,DYNAMIC LINK & RET ADR
5360 T2(T1- K1)= C1:REM INIT ADR OF PROC BLOCK
5370 X1= 6:X2= 0:X3= 0:GOSUB 6310
5375 REM JMP TO STARTING BLOCK ADR
5380 X= T1- K1:GOSUB 6120
5390 IF S0$= "CONST"THEN 5460
5400 IF S0$= "VAR"THEN 5550
5410 IF S0$= "PROC"THEN 5730
5420 IF S0$= "FUNC"THEN 5770
5430 IF S0$= "BEGIN"THEN 5980
5440 E= 25:GOSUB 550
5450 REM *** CONST DCL
5460 GOSUB 1240
5470 GOSUB 2170
5480 K$= ";":E= 5:GOSUB 420:GOSUB 1240
5490 IF S0$= "VAR"THEN 5550
5500 IF S0$= "PROC"THEN 5730
5510 IF S0$= "FUNC"THEN 5770
5520 IF S0$= "BEGIN"THEN 5980
5530 GOTO 5470
5540 REM *** VAR DCL
5550 L= 0:F9= 1
5560 GOSUB 1240:GOSUB 2340
5570 L= L+ 1:IF S0$= ","THEN 5560
5580 K$= ":":E= 5:GOSUB 420
5590 GOSUB 1240:IF S0$= "ARRAY"THEN 5610
5600 K$= "INTEG":E= 36:GOSUB 420:GOTO 5670
5610 K$= "[":E= 33:GOSUB 510:GOSUB 1240:GOSUB 2240
5620 K$= "]":E= 34:GOSUB 510
5621 K$= "OF":E= 26:GOSUB 510
5622 K$= "INTEG":E= 36:GOSUB 510
5630 D0= D0- L
5640 FOR I= T1- L+ 1TO T1
5650 T0$(I)= "A":T3(I)= N3+ 1
5660 T2(I)= D0:D0= D0+ N3+ 1:NEXT I
5670 K$= ";":E= 5:GOSUB 510
5680 GOSUB 1240:IF S0$= "PROC"THEN 5730
5690 IF S0$= "FUNC"THEN 5770
5700 IF S0$= "BEGIN"THEN 5980
5710 L= 0:F9= 1:GOSUB 2340:GOTO 5570
5720 REM *** PROC DCL
5730 K$= "IDENT":E= 4:GOSUB 510
5740 K1= 0:K$= "P":GOSUB 1950
5750 L1= L1+ 1:GOTO 5810
5760 REM *** FUNC DCL
5770 K$= "IDENT":E= 4:GOSUB 510
5780 K$= "F":GOSUB 1950:REM FUNC ADR
5790 L1= L1+ 1:K1= 1
5800 K$= "Y":GOSUB 1950:REM FUNC VAL
5810 K2= K1:GOSUB 1240
5820 X= T1:GOSUB 6120
5830 X= D0:GOSUB 6120
5840 IF S0$< > "("THEN 5890
5850 GOSUB 1240:F9= 0:GOSUB 2340:K1= K1+ 1
5860 IF S0$= ","THEN 5850
5870 K$= ")":E= 22:GOSUB 420
5880 GOSUB 1240:T3(T1- K1)= K1- K2
5890 K$= ";":E= 5:GOSUB 420
5900 FOR I= 1TO K1:REM FUNC VAL & PARS HAVE - OFFSET
5910 T2(T1- I+ 1)= - I:NEXT I
5920 GOSUB 1240:GOSUB 5340:L1= L1- 1
5930 GOSUB 6150:D0= X
5940 GOSUB 6150:T1= X
5950 K$= ";":E= 5:GOSUB 420
5960 GOSUB 1240:GOTO 5410
5970 REM *** START OF EXEC STMNTS
5980 GOSUB 1240:GOSUB 6150:K= X
5990 X= T2(K):GOSUB 6540
6000 T2(K)= C1:REM START BLK ADR
6010 X1= 5:X2= 0:X3= D0:GOSUB 6310
6020 GOSUB 3490
6030 IF S0$< > ";"THEN 6050
6040 GOSUB 1240:GOTO 6020
6050 IF S0$< > "END"THEN E= 17:GOSUB 550
6060 GOSUB 1240
6070 X1= 1:X2= 0:X3= 0:GOSUB 6310
6080 RETURN
6090 REM ****************
6100 REM END PARSER AND CODER
6110 REM ****************
6120 REM PUSH X INTO STACK
6130 S(S9)= X:S9= S9+ 1:RETURN
6140 REM ****************
6150 REM POP X FROM STACK
6160 S9= S9- 1:X= S(S9):RETURN
6170 REM ****************
6180 REM PUSH Y$ INTO STACK
6190 S$(P8)= Y$
6200 P8= P8+ 1
6210 RETURN
6240 REM ****************
6245 REM POP Y$ FROM STACK
6250 P8= P8- 1
6260 Y$= S$(P8)
6270 RETURN
6300 REM ****************
6310 REM GENERATE CODES
6320 B$= " "
6330 POKE P9,X1:POKE P9+ 1,X2
6340 POKE P9+ 2,X3- INT (X3/ 256)* 256
6350 GOSUB 6450:POKE P9+ 3,N
6360 IF Y9< > 0THEN 6400:REM DON'T ECHO INPT FRM KEYBRD
6370 IF X1< 16THEN 6390
6380 B$= "X ":X1= X1- 16:REM INDEX
6390 PRINT C1," ",M$(X1+ 1)+ B$,X2,X3
6400 C1= C1+ 1:P9= P9+ 4
6410 IF P9> = Q9THEN E= 1:GOSUB 550
6420 RETURN
6430 REM ****************
6450 N= INT (X3/ 256)
6460 IF N< 0THEN N= N+ 256
6470 RETURN
6510 REM ****************
6520 REM FIX UP FORWARD REF
6530 GOSUB 6150
6540 M= P7+ X* 4
6550 POKE M+ 2,C1- INT (C1/ 256)* 256:X3= C1
6555 GOSUB 6450:POKE M+ 3,N
6560 IF Y9< > 0THEN RETURN
6570 PRINT "ADR AT",X,"CHANGED TO",C1
6580 RETURN