10 ' ===========================================

12 ' COMPILADOR MINI PASCAL

14 ' Version original
16 ' ===========================================
20 DEFINT A-Z
30 CLEAR 1500
40 N0 = 32
50 T0 = 100
60 N1 = 32767
70 N2 = 8
75 N5=INT(255/N2):T=INT(T0/N4)+1
80 DIM S(100) ' STACK
85 DIM T$(T) ' SYMBOL TABLE
90 PRINT:PRINT "
Pascal P-Code Compiler Generator"
95 PRINT
100 FOR i = 1 TO T:T$(i) = String(N4 * n2, " "):NEXT i
110 T0$ = String$(T0, " ")
140 DIM T1(T0),T2(T0),T3(T0),E1(25),E2(25)
170 W0$="AND ARRAY BEGIN CALL CASE CONST DIV DO
DOWNT ELSE END "
172 W0$=W0$ + "FOR FUNCT IF
INTEG MEM MOD NOT OF
OR
PROCE PROGR "
174 W0$=W0$+ "READ REPEA SHL SHR THEN TO
UNTIL VAR WHILE WRITE"
220 M$ = "LITOPRLODSTOCALINTJMPJPCCSP"
225 E7 = 0:E6 = 1
230 P8 = 1:S9 = 1
235 P7 = 59140:Q9 = 63140
240 PRINT "P-Code start address:";PRINT P7
245 PRINT "P-Code stop address:";PRINT Q9
250 PRINT
260 P9=p7
270 PRINT "File Source:";
280 LINE INPUT$ F$
290 OPEN "I",#1,F$
295 IF F$=":CI:" THEN F$="PCODES":GOTO 340
300 FOR I=1 TO LEN(F$)
310 IF MID$(F$, i, 1) = "." THEN GOTO 330
320 NEXT i
330 IF i < LEN(F$) THEN F$ = MID$(F$, 1, i - 1)
340 OPEN "o",#6,F$+".PCO"
350 OPEN "o",#5,F$+".TMP"
360 X$ = " ":GOSUB 1240 'GET TOKEN
362 K$="PROGR":E9=32:GOSUB 510
364 K$="IDENT":E9=4:GOSUB 500
366 K$=";":E9=10:GOSUB 500
368 GOSUB 1240
370 GOSUB 5340 'BLOCK
380 K$=".":E9=9:GOSUB 510
390 POKE P9,255:POKE P9+1,255:POKE P9+2,255:POKE P9+3,255: 'EOF MARK
400 PRINT:PRINT
405 P9=p9+4:GOSUB 6600
410 CLOSE
420 GOTO 7000
490 ' Error Routines
500 GOSUB 1240
510 IF S0$<>K$ THEN GOSUB 550
520 RETURN
550 '
570 GOSUB 620
580 STOP
590 RETURN
620 ON INT((E9-1)/5)+1 GOTO 630,640,650,660,670,680,690,700
630 ON E9 GOTO 710,720,730,740,750
640 ON E9-5 GOTO 990,990,990,760,770
650 ON E9-10 GOTO 780,790,800,990,990

660 ON E9-15 GOTO 810,820,830,840,850

670 ON E9-20 GOTO 860,870,880,990,890
680 ON E9-25 GOTO 900,910,920,990,930
690 ON E9-30 GOTO 940,990,950,960,970
700 ON E9-35 GOTO 980
710 PRINT "MEM FULL":RETURN
720 PRINT "CONST EXPECTED":RETURN
730 PRINT "'=' EXPECTED":RETURN
740 PRINT "IDENTIFIER EXPECTED":RETURN
750 PRINT "';' OR ':' EXPECTED":RETURN
760 PRINT "'.' EXPECTED":RETURN
770 PRINT "';' MISSING":RETURN
780 PRINT "UNDECLARED IDENTIFIER":RETURN
790 PRINT "ILEGAL 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 OF 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 RECOGNIZED":RETURN
900 PRINT "BUG ":RETURN
910 ' ================================================================
1000 ' SCANNER
1030 ' GetChar
1040 IF c0 < L0 THEN GOTO 1060
1050 GOSUB 1090:GOTO 1040
1060 C0 = C0 + 1:X$=MID$(L$,C0,1)
1065 IF (ASC(XS$) > 96) AND (ASC(XS$) < 123) THEN XS$ = CHR$(ASC(XS$) - 32)
1070 RETURN
1090 ' INPUT a LINE
1100 PRINT TAB(5);c1;TAB(11)
1110 IF EOF(1) THEN PRINT "EOF FOUND":GOTO 480
1120 LINE INPUT #1, L$:IF F$ <> "PCODES" THEN PRINT L$
1130 L$ = L$ + " "
1140 C0 = 0
1150 L0 = LEN(L$)
1160 RETURN
1240 ' Get Token
1260 IF (x$ <> " ") AND (x$ <> CHR$(9)) THEN GOTO 1280
1270 GOSUB 1030:GOTO 1260 ' Flash Blanks
1280 IF X$ < "A" THEN GOTO 1460 :' IdentIFier?
1290 IF X$ > "Z" THEN GOTO 1460
1300 K = 0:a$ = " ": FOR i = 1 TO n2 - 1 :a$ = a$ + " ": NEXT i
1310 'a$ = Space(n2)
1310 IF k >= n2 THEN GOTO 1330
1320 k = k + 1 : MID$(a$, k, 1) = X$
1330 GOSUB 1030
1335 IF X$ = CHR$(&H5F) THEN GOSUB 1030 ' caracter "_"
1340 T = ASC(X$)
1345 ' 47=0 58=9 64=A 91=Z
1350 IF (T > 47 AND T < 58) OR (T > 64 AND T < 91) THEN GOTO 1310

1360
1365
1370
1380
1390
1460
1470
1480
1485
1490
1500
1510
1520
1530
1540
1550
1560
1570
1580
1590
1600
1610
1620
1630
1639
1640
1650
1660
1670
1680
1690
1700
1709
1710
1720
1730
1740
1749
1750
1760
1770
1780
1789
1790
1800
1810
1811
1812
1813
1814
1815
1816
GOTO
1819
1820
1830
1840
1850
1860
1870
1880
1890
1900
1910

' Search FOR reserved words

B$ = MID$(A$, 1, 5)
i = INSTR(W0$, B$)
IF i = 0 THEN S0$ = "IDENT" ELSE S0$ = B$
RETURN
Z$ = ""
IF XS$ < "0" THEN GOTO 1580
IF XS$ > "9" THEN GOTO 1580
' Numeros
S0$ = "NUM"
z$ = z$ + x$
GOSUB 1030
IF ASC(x$) >= 48 AND ASC(x$) <= 57 THEN GOTO 1500
n3 = VAL(Z$)
IF n3 <= n1 THEN RETURN
E9 = 30 : GOSUB 550
n3 = n1:RETURN
'Check FOR special symbol
IF XS$ <> ":" THEN GOTO 1640
GOSUB 1030
IF XS$ = "=" THEN GOTO 1620
S0$ = ":" : RETURN
S0$ = ":="
GOSUB 1030:RETURN
' "<" OR "<>" OR "<="
IF XS$ <> "<" THEN GOTO 1710
GOSUB 1030
IF XS$ = ">" THEN GOTO 1690
IF XS$ = "=" THEN GOTO 1700
S0$ = "<":RETURN
S0$ = "<>":GOSUB 1030:RETURN
S0$ = "<=":GOSUB 1030:RETURN
' ">" OR ">="
IF XS$ <> ">" THEN GOTO 1750
GOSUB 1030:S0$ = ">"
IF XS$ <> "=" THEN RETURN
S0$ = ">=":GOSUB 1030:RETURN
' Strings
IF XS$ <> "'" THEN GOTO 1790
S0$ = "STR":c$ = ""
GOSUB 1030:IF XS$ = "'" THEN GOTO 1030
c$ = c$ + XS$:GOTO 1770
' "{...}" ignore comments
IF XS$ <> "{" THEN GOTO 1812
GOSUB 1030:IF XS$ <> "}" THEN GOTO 1800
GOSUB 1030:GOTO 1240
' "(*...*)" OR "("
IF XS$ <> "(" THEN GOTO 1820
GOSUB 1030
IF XS$ <> "*" THEN C0 = C0 - 1:XS$ = "(":GOTO 1930
GOSUB 1030:IF XS$ <> "*" THEN GOTO 1815
GOSUB 1030:IF XS$ = "*" THEN GOTO 1816 ELSE IF XS$ = ")" THEN GOTO 1810 ELSE
1815
' "%" hex constant
IF XS$ <> "%" THEN GOTO 1930
GOSUB 1030:S0$ = "NUM":n3 = 0
FOR i = 1 TO 4
T = ASC(XS$)
IF T >= 48 AND T <= 57 THEN GOTO 1880
IF T >= 65 AND T <= 70 THEN T = T - 7 ELSE GOTO 1910
T = T - 48
n3 = n3 * 16 + T:GOSUB 1030:NEXT i
RETURN
IF i > 1 THEN E9 = 27:GOSUB 550

1920
1930
1950
1960
1970
1980
1990
2000
2010
2020
2030
2040
2050
2060
2080
2090
2100
2105
2110
2115
2120
2130
2150
2170
2180
2190
2200
2210
2220
2240
2250
2260
2270
2280
2290
2300
2310
2340
2350
2360
2380
2390
2400
2410
2420
2430
2440
2450
2460
2470
2480
2490
2500
2610
2620
2630
2640
2650
2660
2670
2680
2690
2700
2710

S0$ = "%":RETURN
S0$ = XS$:GOTO 1030
' Enter in symbol table
T1 = T1 + 1:T2 = INT((T1 - 1) / N4):T3 = T1 - T2 * N4
MID$(TS$(T2 + 1), (T3 - 1) * n2 + 1, n2) = a$
MID$(T0$, T1, 1) = K$ :' Store Type
IF K$ <> "C" THEN GOTO 2010
T2(T1) = n3 ' Store Value
T1(T1) = L1:T3(T1)=0 :'Store Level of Ident
IF K$ <> "V" THEN GOTO 2050
IF F9 = 0 THEN GOTO 2050
T2(T1) = D0:D0 = D0 + 1 : 'Store Offset
RETURN
' Search in Symbol Table
T2 = INT((T1 - 1) / N4):j = (T1 - 1 - N4 * T2) * n2 + 1:T2 = T2 + 1
FOR i = T1 TO 1 STEP -1
IF a$ = MID$(TS$(T2), j, n2) THEN GOTO 2130
j = j - n2
IF j <= 0 THEN T2 = T2 - 1:j = (N4 - 1) * n2 + 1
NEXT i
i = 0
RETURN
' PASER & CODER
' Constant decl
K$ = "IDENT":E9 = 4:GOSUB 510
K$ = "=":E9 = 3: GOSUB 500
GOSUB 1240:GOSUB 2240
K$ = "C":GOSUB 1950 ' Revisar si es C o c
GOTO 1240
' Get Constant
IF S0$ = "NUM" THEN RETURN
IF S0$ = "IDENT" THEN GOTO 2290
K$ = "STR":E9 = 2:GOSUB 510
n3 = ASC(c$):RETURN
GOSUB 2060:IF i = 0 THEN E9 = 2:GOSUB 550
IF MID$(T0$, i, 1) <> "C" THEN E9 = 2:GOSUB 550
n3 = T2(i):RETURN
' Var Decl
K$ = "IDENT":E9 = 4:GOSUB 510
K$ = "V":GOSUB 1950:GOTO 1240
' Simple expresion
IF S0$ = "-" THEN X=1 ELSE X=0
GOSUB 6120
IF S0$ = "-" OR S0$ = "+" THEN GOSUB 1240
GOSUB 2610
GOSUB 6150:IF x = 1 THEN X1=1:X2=0:X3=1:GOSUB 6300
IF S0$ = "+" THEN X=2:GOSUB 6120:GOTO 2480
IF S0$ = "-" THEN X=3:GOSUB 6120:GOTO 2480
IF S0$ = "OR
" THEN X=14:GOSUB 6120:GOTO 2480
RETURN
GOSUB 1240
GOSUB 2610
X1=1:X2=0:GOSUB6150:X3=X:GOSUB 6300:GOTO 2440
' TERM
GOSUB 2850
IF S0$="*"
THEN X=4:GOSUB 6120:GOTO 2700
IF S0$="DIV " THEN X=5:GOSUB 6120:GOTO 2700
IF S0$="MOD " THEN X=7:GOSUB 6120:GOTO 2700
IF S0$="AND " THEN X=15:GOSUB 6120:GOTO 2700
IF S0$="SHL " THEN X=17:GOSUB 6120:GOTO 2700
IF S0$="SHR " THEN X=18:GOSUB 6120:GOTO 2700
RETURN
GOSUB 1240
GOSUB 2850

2720
2850
2860
2870
2880
2890
2900
2910
2920
2930
2940
2950
2960
2970
2980
2990
3000
3010
3020
3030
3040
3050
3060
3110
3120
3130
3140
3150
3160
3170
3180
3190
3200
3210
3220
3230
3240
3250
3260
3270
3290
3300
3310
3320
3330
3340
3350
3360
3370
3380
3390
3400
3410
3420
3490
3500
3510
3520
3530
3540
3550
3560
3570
3580

X1 = 1: X2 = 0:GOSUB 6150:X3 = x: GOSUB 6300:GOTO 2630

' Factor
IF S0$ = "IDENT" THEN GOTO 2930
IF S0$ = "NUM" THEN X1 = 0: X2 = 0: X3 = n3: GOSUB 6300:GOTO 1240
IF S0$ = "STR" THEN X1 = 0: X2 = 0: X3 = ASC(c$): GOSUB 6300:GOTO 1240
IF S0$ = "(" THEN GOTO 3110
IF S0$ = "MEM " THEN GOTO 3150
IF S0$ = "NOT " THEN GOTO 3230
E9 = 23:GOSUB 550
' IdentIFier
GOSUB 2060:IF i = 0 THEN E9 = 11:GOSUB 550
ON INSTR("PYACVF", MID$(T0$, i, 1)) GOTO 2960, 2970, 2990, 3050, 3060, 3060
E9 = 21:GOSUB 550
X1 = 5: X2 = 0: X3 = 1: GOSUB 6300
i = i - 1:GOTO 4290
X = i: GOSUB 6120
K$ = "[":E9 = 33:GOSUB 500
GOSUB 1240
GOSUB 3290
K$ = "]":E9 = 34:GOSUB 510
GOSUB 6150:X1 = 18: X2 = L1 - T1(x): X3 = T2(x): GOSUB 6300:GOTO 1240
X1 = 0: X2 = 0: X3 = T_2(i): GOSUB 6300:GOTO 1240
X1 = 2: X2 = l1 - T1(i): X3 = T2(i): GOSUB 6300:GOTO 1240
' Parentesis Expresion
GOSUB 1240
GOSUB 3290
IF S0$ = ")" THEN GOTO 1240 ELSE E9 = 22:GOSUB 550:RETURN
' Mem
K$ = "[":E9 = 33:GOSUB 500
GOSUB 1240
GOSUB 3290
K$ = "]":E9 = 34:GOSUB 510
GOSUB 1240
X1 = 2: X2 = 255: X3 = 0: GOSUB 6300
RETURN
' NOT
GOSUB 1240
GOSUB 2850
X1 = 1: X2 = 0: X3 = 16: GOSUB 6300
RETURN
' Expresion
GOSUB 2390
IF S0$="=" THEN X=8:GOTO 3380
IF S0$="<>" THEN X=9:GOTO 3380
IF S0$="<" THEN X=10:GOTO 3380
IF S0$=">=" THEN X=11:GOTO 3380
IF S0$=">" THEN X=12:GOTO 3380
IF S0$="<=" THEN X=13:GOTO 3380
RETURN
GOSUB 6120
GOSUB 1240
GOSUB 2390
X1 = 1: X2 = 0:GOSUB 6150:X3 = x:GOSUB 6300
RETURN
' Statement
IF S0$="IDENT" THEN GOTO 3630
IF S0$="IF
" THEN GOTO 4440
IF S0$="FOR " THEN GOTO 5170
IF S0$="WHILE" THEN GOTO 4800
IF S0$="CASE " THEN GOTO 4890
IF S0$="REPEA" THEN GOTO 4730
IF S0$="BEGIN" THEN GOTO 4590
IF S0$="READ " THEN GOTO 4040
IF S0$="WRITE" THEN GOTO 3870

3590 IF S0$="MEM " THEN GOTO 4650

3600 IF S0$="CALL " THEN GOTO 4240
3610 RETURN
3620 'Asignement
3630 GOSUB 2060
3640 IF i = 0 THEN E9=11:GOSUB 550
3650 IF MID$(T0$, i, 1) = "A" THEN GOTO 3700 ' Array
3660 IF MID$(T0$, i, 1) = "V" THEN GOTO 3760 ' Var
3670 IF MID$(T0$, i, 1) = "Y" THEN GOTO 3760 ' Func RETURN value
3680 IF MID$(T0$, i, 1) = "P" THEN GOTO 4290 ' Proc call
3690 E9=12:GOSUB 550
3700 X=I:GOSUB 6120
3710 X=16:GOSUB 6120
3720 K$ = "[":E9=33:GOSUB 500
3730 GOSUB 1240
3740 K$ = "]":E9=34:GOSUB 510
3750 GOTO 3780
3760 X=I:GOSUB 6120
3770 X=0:GOSUB 6120
3780 GOSUB 1240
3790 IF S0$ = ":=" THEN GOTO 3810
3800 E9=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 6300
3850 RETURN
3860 ' WRITE
3870 K$ = "(":E9 = 31:GOSUB 500
3880 GOSUB 1240:IF S0$ <> "STR" THEN GOTO 3950
3890 L = LEN(c$):IF L > 1 THEN GOTO 3910
3900 X1 = 0: X2 = 0: X3 = ASC(c$): GOSUB 6300:X1 = 8: X2 = 0: X3 = 1: GOSUB
6300:GOTO 3940
3910 FOR i = 1 TO L
3920 X1 = 0: X2 = 0: X3 = ASC(MID$(c$, i, 1)): GOSUB 6300:NEXT i
3930 X1 = 0: X2 = 0: X3 = L: GOSUB 6300:X1 = 8: X2 = 0: X3 = 8: GOSUB 6300
3940 GOSUB 1240:GOTO 4000
3950 GOSUB 3290:k = 1
3960 IF S0$ = "#" THEN k = 3
3970 IF S0$ = "%" THEN k = 5
3980 IF k > 1 THEN GOSUB 1240
3990 X1 = 8: X2 = 0: X3 = k: GOSUB 6300
4000 IF S0$ = "," THEN GOTO 3880
4010 K$ = ")":E9 = 22:GOSUB 510
4020 GOTO 1240
4030 ' READ
4040 K$ = "(":E9 = 31:GOSUB 500
4050 K$ = "IDENT":E9 = 4:GOSUB 500
4060 GOSUB 2060:IF i = 0 THEN E9 = 11:GOSUB 550
4070 X = i: GOSUB 6120
4080 IF MID$(T0$, i, 1) = "A" THEN GOTO 4190
4090 IF MID$(T0$, i, 1) = "V" THEN L = 0 ELSE E9 = 4:GOSUB 550
4100 GOSUB 1240:k = 0
4110 IF S0$ = "#" THEN k = 2
4120 IF S0$ = "%" THEN k = 4
4130 X1 = 8: X2 = 0: X3 = k: GOSUB 6300
4140 IF k > 0 THEN GOSUB 1240
4150 GOSUB 6150:X1 = L + 3: X2 = L1 - T1(x): X3 = T2(x): GOSUB 6300
4160 IF S0$ = "," THEN GOTO 4050
4170 K$ = ")":E9 = 31:GOSUB 510
4180 GOTO 1240
4190 K$ = "I":E9 = 33:GOSUB 500
4200 GOSUB 1240:GOSUB 3290
4210 K$ = "]":E9 = 34:GOSUB 510

4220
4230
4240
4250
4260
4270
4280
4290
4300
4310
4320
4330
4340
4350
4360
4370
4380
4390
4400
4410
4420
4430
4440
4450
4460
4470
4480
4490
4500
4510
4520
4530
4540
4550
4560
4570
4580
4590
4600
4610
4620
4630
4640
4650
4660
4670
4680
4690
4700
4710
4720
4730
4740
4750
4760
4770
4780
4790
4800
4810
4820
4830
4840
4850

L = 16:GOTO 4100
' Absolute Mem Call
K$ = "(":E9 = 31:GOSUB 500
GOSUB 1240:GOSUB 3290
K$ = ")":E9 = 22:GOSUB 510
X1 = 4: X2 = 255: X3 = 0: GOSUB 6300:GOTO 1240
' Procedure OR FunctiON Call
k2 = 0:k3 = i
IF T3(i) = 0 THEN GOTO 4400 ' No parameters
K$ = "(":E9 = 31:GOSUB 500
X = k2: GOSUB 6120
X = k3: GOSUB 6120
GOSUB 1240:GOSUB 3290
GOSUB 6150:k3 = x
GOSUB 6150:k2 = x:k2 = k2 + 1
IF S0$ = "," THEN GOTO 4320
IF k2 <> T3(k3) THEN E9 = 35:GOSUB 550
K$ = ")":E9 = 22:GOSUB 510
X1 = 4: X2 = L1 - T1(k3): X3 = T2(k3):GOSUB 6300
IF k2 <> 0 THEN X1 = 5: X2 = 0: X3 = -k2:GOSUB 6300
GOTO 1240
' IF, THEN, Else
GOSUB 1240
GOSUB 3290
K$ = "THEN ":E9 = 16:GOSUB 510
GOSUB 1240
X = c1: GOSUB 6120 ' Forward ref point
X1 = 7: X2 = 0: X3 = 0:GOSUB 6300 'JPC
GOSUB 3490
IF S0$ <> "ELSE " THEN GOTO 6520
GOSUB 6150:k = x
X = c1: GOSUB 6120
X1 = 6: X2 = 0: X3 = 0:GOSUB 6300
x = k:GOSUB 6540 ' Fixup Forwd Ref
GOSUB 1240:GOSUB 3490
GOTO 6520
' Compound Statement
GOSUB 1240
GOSUB 3490
IF S0$ = ";" THEN GOTO 4590
IF S0$ = "END " THEN GOTO 1240
E9 = 17:GOSUB 550:RETURN
' Write Memory
K$ = "[":E9 = 33:GOSUB 500
GOSUB 1240:GOSUB 3290
IF S0$ <> "]" THEN E9 = 34:GOSUB 550
K$ = ":=":E9 = 13:GOSUB 500
GOSUB 1240:GOSUB 3290
X1 = 3: X2 = 255: X3 = 0:GOSUB 6300
RETURN
' Repeat Until
X = c1: GOSUB 6120
GOSUB 1240:GOSUB 6120
IF S0$ = ";" THEN GOTO 4740
K$ = "UNTIL":E9 = 10:GOSUB 510
GOSUB 1240:GOSUB 3290
GOSUB 6150:X1 = 7: X2 = 0: X3 = x:GOSUB 6300:RETURN
' While Do
GOSUB 1240:X = c1: GOSUB 6120
GOSUB 3290: X = c1: GOSUB 6120
X1 = 7: X2 = 0: X3 = 0:GOSUB 6300
K$ = "DO
":E9 = 18:GOSUB 510
GOSUB 1240:GOSUB 3490
GOSUB 6150:k = x:GOSUB 6150

4860
4870
4880
4890
4900
4910
4920
4930
4940
X2 =
4950
4960
4970
4980
4990
5000
5010
5020
5030
5040
5050
5060
5070
5080
5090
5100
5110
5120
5130
5140
5150
5160
5170
5180
5190
5200
5210
5220
5230
5240
5250
5260
5270
5280
5290
5300
5310
5320
5340
5350
5360
5370
5380
5390
5400
5410
5420
5430
5440
5450
5460
5470
5480
5490

X1 = 6: X2 = 0: X3 = x:GOSUB 6300
x = k:GOSUB 6540
' Case Of
GOSUB 1240:GOSUB 3290
K$ = "OF
":E9 = 25:GOSUB 510
i2 = 1 ' # of case statements
i1 = 0 ' # of case labels
GOSUB 1240:GOSUB 2240
X1 = 1: X2 = 0: X3 = 21:GOSUB 6300:X1 = 0: X2 = 0: X3 = n3:GOSUB 6300:X1 = 1:
0: X3 = 8:GOSUB 6300
GOSUB 1240:IF S0$ = ":" THEN GOTO 4990
K$ = ",":E9 = 5:GOSUB 510
X = c1: GOSUB 6120:X1 = 7: X2 = 1: X3 = 0:GOSUB 6300
i1 = i1 + 1:GOTO 4930
k = c1:X1 = 7: X2 = 0: X3 = 0:GOSUB 6300
FOR i = 1 TO i1:GOSUB 6520:NEXT i
X = k: GOSUB 6120
GOSUB 1240: X = i2: GOSUB 6120
GOSUB 3490:GOSUB 6150:i2 = x
IF S0$ = "ELSE " THEN GOTO 5090
IF S0$ <> ";" THEN GOTO 5130
k = c1:X1 = 6: X2 = 0: X3 = 0:GOSUB 6300
GOSUB 6520
X = k: GOSUB 6120:i2 = i2 + 1:GOTO 4920
k = c1:X1 = 6: X2 = 0: X3 = 0:GOSUB 6300:GOSUB 6520
X = k: GOSUB 6120
GOSUB 1240:X = i2: GOSUB 6120
GOSUB 3490:GOSUB 6150:i2 = x
K$ = "END ":E9 = 17:GOSUB510
FOR i = 1 TO i2 GOSUB 6520:NEXT i
X1 = 5: X2 = 0: X3 = -1:GOSUB 6300:GOTO 1240
' FOR
K$ = "IDENT":E9 = 4:GOSUB 500
GOSUB 3630:GOSUB 6120
F9 = 1:IF S0$ = "TO
" THEN GOTO 5210
K$ = "DOWNT":E9 = 28:GOSUB 510:F9 = 0
GOSUB 1240:GOSUB 3290
GOSUB 6150:k = x:X = c1: GOSUB 6120
X1=1: X2=0: X3=21:GOSUB 6300:X1 = 2: X2 = L1 - T1(k): X3 = T2(k):GOSUB 6300
X1=1:X2=0:X3=13-F9-F9:GOSUB 6300:X=c1:GOSUB 6120:X1=7:X2=0:X3= 0:GOSUB 6300
X = F9: GOSUB 6120: X = k: GOSUB 6120
K$ = "DO
":E9 = 18:GOSUB 510:GOSUB 1240
GOSUB 3490:GOSUB 6150:X1 = 2: X2 = L1 - T1(x): X3 = T2(x):GOSUB 6300
k = x:GOSUB 6150:X1 = 1: X2 = 0: X3 = 20 - x:GOSUB 6300
X1 = 3: X2 = L1 - T1(k): X3 = T2(k):GOSUB 6300
GOSUB 6150:k = x:GOSUB 6150:X1 = 6: X2 = 0: X3 = x:GOSUB 6300
x = k:GOSUB 6540
X1 = 5: X2 = 0: X3 = -1:GOSUB 6300:RETURN
' Block
d0 = 3
T2(T1 - k1) = c1
X1 = 6: X2 = 0: X3 = 0:GOSUB 6300
X = T1 - k1: GOSUB 6120
IF S0$ = "CONST" THEN GOTO 5460
IF S0$ = "VAR " THEN GOTO 5550
IF S0$ = "PROCE" THEN GOTO 5730
IF S0$ = "FUNCT" THEN GOTO 5770
IF S0$ = "BEGIN" THEN GOTO 5980
E9 = 25:GOSUB 550
' Constant declaration
GOSUB 1240
GOSUB 2170
K$ = ";":E9 = 5:GOSUB 510:GOSUB 1240
IF S0$ = "VAR " THEN GOTO 5550

5500
5510
5520
5530
5540
5550
5560
5570
5580
5590
5600
5610
5620
5630
5640
5650
5660
5670
5680
5690
5700
5710
5720
5730
5740
5750
5760
5770
5780
5790
5800
5810
5820
5830
5840
5850
5860
5870
5880
5890
5900
5910
5920
5930
5940
5950
5960
5970
5980
5990
6000
6010
6020
6030
6040
6050
6060
6070
6080
6090
6100
6110
6120
6130

IF S0$ = "PROCE" THEN GOTO 5730

IF S0$ = "FUNCT" THEN GOTO 5770
IF S0$ = "BEGIN" THEN GOTO 5980
GOTO 5470
' Variable Declaration
L = 0:F9 = 1
GOSUB 1240:GOSUB 2340
L = L + 1:IF S0$ = "," THEN GOTO 5560
K$ = ":":E9 = 5:GOSUB 510
GOSUB 1240:IF S0$ = "ARRAY" THEN GOTO 5610
K$ = "INTEG":E9 = 36:GOSUB 510:GOTO 5670
K$ = "[":E9 = 33:GOSUB 500:GOSUB 1240:GOSUB 2240
K$ ="]":E9=34:GOSUB 500:K$="OF
":E9=26:GOSUB 500:K$="INTEG":E9=36:GOSUB 500
d0 = d0 - L
FOR i = T1 - L + 1 TO T1
MID$(T0$, i, 1) = "A":T3(i) = n3 + 1
T2(i) = d0:d0 = d0 + n3 + 1:NEXT i
K$ = ";":E9 = 5:GOSUB 500
GOSUB 1240:IF S0$ = "PROCE" THEN GOTO 5730
IF S0$ = "FUNCT" THEN GOTO 5770
IF S0$ = "BEGIN" THEN GOTO 5980
L = 0:F9 = 1:GOSUB 2340:GOTO 5570
' Procedure Declaration
K$ = "IDENT":E9 = 4:GOSUB 500
k1 = 0:K$ = "P":GOSUB 1950
L1 = L1 + 1:GOTO 5810
' FunctiON declaration
K$ = "IDENT":E9 = 4:GOSUB 500
K$ = "F":GOSUB 1950
L1 = L1 + 1:k1 = 1
K$ = "Y":GOSUB 1950
k2 = k1:GOSUB 1240
X = T1: GOSUB 6120
X = d0: GOSUB 6120
IF S0$ <> "(" THEN GOTO 5890
GOSUB 1240:F9 = 0:GOSUB 2340:k1 = k1 + 1
IF S0$ = "," THEN GOTO 5850
K$ = ")":E9 = 22:GOSUB 510
GOSUB 1240:T3(T1 - k1) = k1 - k2
K$ = ";":E9 = 5:GOSUB 510
FOR i = 1 TO k1
T2(T1 - i + 1) = -i:NEXT i
GOSUB 1240:GOSUB 5340:L1 = L1 - 1
GOSUB 6150:d0 = x
GOSUB 6150:T1 = x
K$ = ";":E9 = 5:GOSUB 510
GOSUB 1240:GOTO 5410
' Start of executable statements
GOSUB 1240:GOSUB 6150: k = x
x = T2(k):GOSUB 6540
T2(k) = c1
x1=5:x2=0:x3=D0:GOSUB 6300
GOSUB 3490
IF S0$ <> ";" THEN GOTO 6050
GOSUB 1240:GOTO 6020
IF S0$ <> "END " THEN E9=17:GOSUB 550
GOSUB 1240
x1=1:x2=0:x3=0:GOSUB 6300
RETURN
' END PARSER & CODER
'
'
' PUSH X
S(S9) = x:S9 = S9 + 1:RETURN

6140
6150
6160
6170
6300
6330
6340
6350
6360
6365
6370
6380
6390
6395
6400
6410
6420
6430
6520
6530
6540
6545
6550
6560
6565
6570
6575
6580
6590
6600
6610
6620
6630
6640
6650
6900
7000
7010
7015
7020
7030
7040
7050
7060
7070
7075
7080
7090
7100
7110
7115
7120
7130
7140
7150
7160
7165
7170
7175
7180
7190
7200
7210
7220

'
' POP X
S9 = S9 - 1:X = S(S9):RETURN
'
' P-codes generation
B$ = "
"
POKE P9, x1:POKE P9 + 1, x2
n = X3 - INT(X3 / 256) * 256:POKE P9 + 2, n
n = INT(X3 / 256):IF n < 0 THEN n = 256 + n
POKE P9 + 3, n
IF X1 < 16 THEN GOTO 6390
MID$(B$, 1, 1) = "X":X1 = X1 - 16
'
PRINT #6, TAB(4) c1;TAB(10) MID$(MN$, X1 * 3 + 1, 3);B$; "
";x2;"
c1 = c1 + 1:P9 = P9 + 4
IF P9 >= Q9 THEN GOSUB 6600
RETURN
'
' Fixud forward references
GOSUB 6150
m = P7 + x * 4 - (Q9 - P7) * E7
IF m < P7 THEN GOTO 6570
n = c1 - INT(c1 / 256) * 256:POKE m + 2, n
n = INT(c1 / 256)
POKE m + 3, n:GOTO 6575
E1(E6) = c1:E2(E6) = x:E6 = E6 + 1
PRINT #6, TAB(4) "address AT" x; "changed to" c1
RETURN
' pcodes page TO floppy
FOR i7 = P7 TO (P9 - 4) STEP 4
PRINT #5, PEEK(i7), PEEK(i7 + 1), PEEK(i7 + 2), PEEK(i7 + 3)
NEXT i7
P9 = P7
E7 = E7 + 1
RETURN
'
OPEN "I",#5,f$+".TMP"
OPEN "O",#6,F$+".COD"
' Table bubble sort
e5 = E6 - 1
FOR i = 1 TO e5 - 1
e4 = 0
FOR j = (e5 - 1) TO i STEP -1
IF E2(j) <= E2(j + 1) THEN GOTO 7080
e3 = E2(j):E2(j) = E2(j + 1):E2(j + 1) = e3:e4 = 1
e3 = E1(j):E1(j) = E1(j + 1):E1(j + 1) = e3
NEXT j
IF e4 = 0 THEN GOTO 7110
NEXT i
E2(e5 + 1) = 32767
' Copy file.TMP
c1 = -1:E6 = 1:L$ = "'":e0 = E7:E7 = -1
FOR j = 1 TO e0
P9 = P7
IF EOF(5) THEN GOTO 7180
FOR i = 1 TO 4:INPUT #5, x:POKE P9, x:P9 = P9 + 1:NEXT i:c1 = c1 + 1
IF P9 >= Q9 THEN E7 = E7 + 1:GOTO 7180
GOTO 7150
'
IF c1 < E2(E6) THEN GOTO 7260
m = P7 + E2(E6) * 4 - (Q9 - P7) * E7
n = E1(E6) - INT(E1(E6) / 256) * 256
POKE m + 2, n
n = INT(E1(E6) / 256)

"; x3

7230
7240
7250
7255
7260
7270
7280
7290
7300
7310
7400
7430
7440
7450
7460
7490
7500
7510
7520
7530
7540
7550
7560
7570
7580
7600

POKE m + 3, n
E6 = E6 + 1
GOTO 7180
'
FOR k = P7 TO P9 - 1
L$ = L$ + CHR$(PEEK(k))
IF LEN(L$) >= 126 THEN PRINT #6, L$:L$ = "*"
NEXT k
NEXT j
PRINT #6, L$
Close
KILL F$ + ".tmp"
PRINT
PRINT c1*4;" bytes of p-codes"
IF e0 > 1 THEN PRINT "p-codes located in";f$+".COD"
PRINT
PRINT "PRINT p-codes";: INPUT y$
IF y$="" THEN 7600
OPEN "i",#6,f$+".PCO"
PRINT CHR$(0cH)
IF EOF(6) THEN GOTO 7580
LINE INPUT #6,L$
PRINT l$
GOTO 7540
close
END