100 REM ****************************
110 REM *                          *
120 REM *       FORTH-COMPILER     *
130 REM *                          *
140 REM *           FUER           *
150 REM *                          *
160 REM *        COMMODORE-64      *
170 REM *                          *
180 REM ****************************
190 REM *                          *
200 REM *  ALEXANDER SCHINDOWSKI   *
210 REM *                          *
220 REM *  6000 FRANKFURT/MAIN 50  *
230 REM *                          *
240 REM * RUDOLF-HILFERDING-STR.49 *
250 REM *                          *
260 REM ****************************
270 REM *                          *
280 REM *  TELEPHON:(069)/570520   *
290 REM *                          *
300 REM ****************************
310 :
320 :
330 :
340 IF A=0 THENA=1:LOAD"VOCABULARY",8,1
350 DEF FNH(X)=(INT(X/256))
360 DEF FNL(X)=(X-256*FNH(X))
370 POKE 53272,23:PRINT"[147][154]";CHR$(8);
380 VOC=6*4096:BE=VOC:SP=0:Z1=0
390 POKE 55,FN L(BE):POKE 56,FN H(BE)
395 DIM ST(20),SC$(24),WO$(100),AD(100)
400 PRINT TAB(14);"[198]ORTH-[195]OMPILER"
410 PRINT TAB(17);"FUER DEN"
420 PRINT TAB(15);"[195]OMMODORE-64"
430 PRINT"----------------------------------------";
440 PRINT"     [214]ON [193]LEXANDER [211]CHINDOWSKI 1985"
450 DATA 38
460 DATA "+",49563
470 DATA "CLS",49158,"DEPTH",49968
480 DATA "@",50012,"DROP",49236
490 DATA "EMIT",49855,"EXPECT",49936
500 DATA "=",49410,"I",49766
510 DATA "KEY",49880
520 DATA "+LOOP",49821,"MOD",49733
530 DATA "NOT",49458,"OVER",49284
540 DATA ".",49163,"-",49578
550 DATA "SWAP",49248,">R",49751
560 DATA "AND",49497,"CR",49384
570 DATA "/",49721,"DO",49757,"!",49977
580 DATA "DUP",49239,"XOR",49541
590 DATA "GET",49862,">",49434
600 DATA "<",49452,"LOOP",49811
610 DATA "*",49596,"OR",49519
620 DATA "C@",50030,"C!",49996
630 DATA "R>",49745,"TYPE",49915
640 DATA "PICK",50062,"CALL",50047,"ROT",50085
650 READ AN
660 FOR I=1 TO AN
670 READ WO$(I),AD(I)
680 NEXT I:POKE 2,0:POKE 252,0
690 GOSUB 3830
693 :
695 REM **************************
700 REM *** BEFEHLS-AUSWERTUNG ***
705 REM **************************
708 :
710 GOSUB 2630
715 :
720 IF BE$=":" THEN 1540
725 :
730 FOR I=AN TO 1 STEP -1
740 IF BE$=WO$(I) THEN 760
750 NEXT I:GOTO 770
760 SYS AD(I):GOTO 700
765 :
770 GOSUB 3030
780 IF OK=0 THEN 830
790 POKE 781,FN L(XX)
800 POKE 780,FN H(XX)
810 SYS 49194
820 GOTO 700
825 :
830 IF BE$="RESET" THEN RUN
835 :
840 IF BE$="BASIC" THEN END
845 :
850 IF BE$<>"VLIST" THEN 900
860 PRINT:FOR I=AN TO 1 STEP-1
870 PRINT WO$(I)"  ";
880 NEXT:PRINT
890 GOTO 700
895 :
900 IF BE$<>"FORGET" THEN 950
910 GOSUB 2630:FOR I=AN TO 1 STEP-1
920 IF BE$<>WO$(I) THEN NEXT I
930 IF I>AN THEN PRINT BE$" [201] CAN'T FIND":GOTO 700
935 :
940 VOC=AD(I):AN=I-1:GOTO 700
950 IF BE$<>"(" THEN 980
960 IF BE$<>")" THEN GOSUB2630:GOTO960
970 GOTO 700
975 :
980 IF BE$<>"EDIT" THEN 1020
990 GOSUB 2630 :SC=VAL(BE$)
1000 PRINT"[211]CREEN:";SC:GOSUB 3280
1010 IF BE$="-->"THEN ZE$="":SC=SC+1:GOTO1000
1012 GOTO 700
1015 :
1020 IF BE$<>"LOAD" THEN 1050
1030 GOSUB 2630:SC=VAL(BE$)
1040 BLOCK=1:Z1=0:GOSUB 3110:GOTO 700
1050 IF BE$<>"-->" THEN 1070
1060 SC=SC+1:GOSUB3110:COMP=1:BLOCK=1:Z1=0:GOTO 700
1070 :
1080 IF BE$<>"VARIABLE" THEN 1145
1085 GOSUB 2630:AN=AN+1:WO$(AN)=BE$
1090 AD(AN)=VOC:XX=VOC+8
1095 GOSUB 3470:POKE VOC,169
1100 POKE VOC+1,FN H(XX)
1105 POKE VOC+2,162
1110 POKE VOC+3,FN L(XX)
1115 POKE VOC+4,32:POKE VOC+5,42
1120 POKE VOC+6,192:POKE VOC+7,96
1125 POKE VOC+8,FN L(X)
1130 POKE VOC+9,FN H(X)
1135 VOC=VOC+10
1140 GOTO 700
1145 :
1150 IF BE$<>"MEMORY" THEN 1220
1155 GOSUB 2630:AN=AN+1:WO$(AN)=BE$
1160 AD(AN)=VOC
1165 GOSUB 3470:POKE VOC,169
1170 POKE VOC+1,FN H(VOC+12)
1175 POKE VOC+2,162
1180 POKE VOC+3,FN L(VOC+12)
1185 POKE VOC+4,32:POKE VOC+5,42
1190 POKE VOC+6,192:AD=VOC+12+XX
1195 POKE VOC+7,96
1200 POKE VOC+8,FN L(AD):POKE VOC+9,FN H(AD)
1205 POKE VOC+10,FN L(XX):POKE VOC+11,FN H(XX)
1210 VOC=AD:GOTO 700
1220 :
1230 IF BE$<>"CONSTANT" THEN 1280
1240 GOSUB 2630:A$=": "+BE$+" "
1250 GOSUB 3470
1260 ZE$=A$+STR$(X)+" ;"+ZE$
1270 GOTO 700
1280 :
1290 IF BE$<>"CLEAR" THEN 1350
1300 GOSUB 2630:SC=VAL(BE$)
1310 FOR ZE=0 TO 24
1320 SC$(ZE)=""
1330 NEXT ZE:GOSUB3220
1340 GOTO700
1350 :
1360 IFBE$="SAVE-SYSTEM"THEN3510
1365 :
1370 IFBE$="LOAD-SYSTEM"THEN3720
1380 :
1390 IF BE$<>"FLOPPY" THEN 1420
1400 GOSUB2630
1410 OPEN1,8,15,BE$:CLOSE1:GOTO 700
1420 :
1430 IFBE$<>"LIST" THEN 1520
1440 GOSUB2630:SC=VAL(BE$):GOSUB3110
1450 INPUT"[193]UF [196]RUCKER (Y/N)";A$:A=3:IFA$="Y"THENA=4
1460 OPEN4,A,-7*(A=4)
1470 FOR Z=0 TO 23
1480 PRINT#4,RIGHT$(STR$(Z),2)":"SC$(Z)
1490 NEXT Z:CLOSE4
1500 IFA=3THENPOKE198,0:WAIT198,1
1510 COMP=0:GOTO700
1520 :
1530 PRINTBE$" [201] CAN'T FIND":GOTO 700
1533 :
1535 REM *************************
1540 REM ***     COMPILER      ***
1545 REM *************************
1548 :
1550 GOSUB2630:AN=AN+1:WO$(AN)=BE$
1560 AD(AN)=VOC:COMP=1
1570 :
1580 GOSUB 2630
1590 FOR I=1 TO ANZ
1600 IF BE$<>WO$(I) THEN NEXT I
1610 AD=AD(I)
1615 :
1620 IF BE$<>"BEGIN" THEN 1640
1630 ST(SP)=VOC:SP=SP+1:GOTO 1570
1635 :
1640 IF BE$<>"UNTIL" THEN 1730
1650 POKE VOC,32
1660 POKE VOC+1,180:POKE VOC+2,194
1670 POKE VOC+3,176:POKE VOC+4,3
1680 POKE VOC+5,76
1690 SP=SP-1:AD=ST(SP):IF SP<0 THEN65535
1700 POKE VOC+6,FN L(AD)
1710 POKE VOC+7,FN H(AD)
1720 VOC=VOC+8:GOTO 1570
1725 :
1730 IF BE$=";" THEN POKE VOC,96:VOC=VOC+1:COMP=0:GOTO 700
1735 :
1740 GOSUB 3030
1750 IF OK=0 THEN 1800
1760 POKE VOC,169:POKE VOC+1,FN H(XX)
1770 POKEVOC+2,162:POKEVOC+3,FN L(XX)
1780 POKE VOC+4,32:POKE VOC+5,42
1790 POKE VOC+6,192:VOC=VOC+7:GOTO 1570
1800 :
1810 IF BE$<>"IF" THEN 1870
1820 POKE VOC,32:POKE VOC+1,180
1830 POKE VOC+2,194:POKE VOC+3,176
1840 POKE VOC+4,3:POKE VOC+5,76
1850 ST(SP)=VOC+6:SP=SP+1
1860 VOC=VOC+8:GOTO 1570
1870 :
1880 IF BE$<>"ENDIF" THEN 1930
1890 SP=SP-1:AD=ST(SP)
1900 POKE AD,FN L(VOC)
1910 POKE AD+1,FN H(VOC)
1920 GOTO 1570
1930 :
1940 IF BE$<>"ELSE" THEN 2010
1950 AD=ST(SP-1)
1960 ST(SP-1)=VOC+1
1970 POKE VOC,76:VOC=VOC+3
1980 POKE AD,FN L(VOC)
1990 POKE AD+1,FN H(VOC)
2000 GOTO 1570
2010 :
2020 IF BE$="WHILE" THEN 1820
2030 :
2040 IF BE$<>"REPEAT" THEN 2110
2050 AD=ST(SP-1):A2=ST(SP-2)
2060 SP=SP-1
2070 POKE VOC,76
2080 POKE VOC+1,FN L(A2)
2090 POKE VOC+2,FN H(A2)
2100 VOC=VOC+3:GOTO 1980
2110 :
2120 IF BE$<>"."+CHR$(34) THEN 2225
2125 A$="":ZE$=MID$(ZE$,2)
2130 IF LEFT$(ZE$,1)<>CHR$(34) THEN A$=A$+LEFT$(ZE$,1):ZE$=MID$(ZE$,2):GOTO2130
2135 ZE$=MID$(ZE$,2):A$=A$+CHR$(0)
2140 AD=VOC+10
2145 POKE VOC,169
2150 POKE VOC+1,FN H(AD)
2155 POKE VOC+2,162
2160 POKE VOC+3,FN L(AD)
2165 POKE VOC+4,32:POKE VOC+5,234
2170 POKE VOC+6,194:POKE VOC+7,76
2175 AD=VOC+10+LEN(A$)
2180 POKE VOC+8,FN L(AD)
2185 POKE VOC+9,FN H(AD)
2190 VOC=VOC+10
2200 FOR I=0 TO LEN(A$)-1
2205 POKE VOC+I,ASC(MID$(A$,I+1,1))
2210 IF LEFT$(ZE$,1)=" " THEN ZE$=MID$(ZE$,2):GOTO 2210
2215 NEXT I
2220 VOC=AD:GOTO 1570
2225 :
2230 IF BE$<>"TEXT"+CHR$(34) THEN2320
2235 A$="":ZE$=MID$(ZE$,2)
2240 IF LEFT$(ZE$,1)<>CHR$(34) THEN A$=A$+LEFT$(ZE$,1):ZE$=MID$(ZE$,2):GOTO2240
2245 ZE$=MID$(ZE$,2):A$=A$+CHR$(0)
2250 AD=VOC+10
2255 POKE VOC,169
2260 POKE VOC+1,FN H(AD)
2265 POKE VOC+2,162
2270 POKE VOC+3,FN L(AD)
2273 POKE VOC+4,32:POKE VOC+5,42:POKE VOC+6,192
2275 POKE VOC+7,76
2280 AD=VOC+10+LEN(A$)
2285 POKE VOC+8,FN L(AD)
2290 POKE VOC+9,FN H(AD)
2295 VOC=VOC+10
2300 FOR I=0 TO LEN(A$)-1
2305 POKE VOC+I,ASC(MID$(A$,I+1,1)):NEXT
2310 IF LEFT$(ZE$,1)=" " THEN ZE$=MID$(ZE$,2):GOTO 2310
2315 VOC=AD:GOTO 1570
2320 :
2330 IF BE$<>"DO" THEN 2390
2340 POKE VOC,32
2350 POKE VOC+1,FN L(AD)
2360 POKE VOC+2,FN H(AD)
2370 VOC=VOC+3:ST(SP)=VOC
2380 SP=SP+1:GOTO 1570
2390 :
2400 IF BE$<>"LOOP" AND BE$<>"+LOOP" THEN 2500
2410 POKE VOC,32
2420 POKE VOC+1,FN L(AD)
2430 POKE VOC+2,FN H(AD)
2440 POKE VOC+3,176:POKE VOC+4,3
2450 SP=SP-1:AD=ST(SP)
2460 POKE VOC+5,76
2470 POKE VOC+6,AD-256*INT(AD/256)
2480 POKE VOC+7,INT(AD/256)
2490 VOC=VOC+8:GOTO 1570
2500 :
2510 IF BE$<>"(" THEN 2540
2520 GOSUB 2630:IF BE$<>")" THEN 2520
2530 GOTO 1570
2540 :
2550 IF BE$=";S" THEN POKE VOC,96:VOC=VOC+1:GOTO 1570
2560 :
2570 IF I>AN THEN PRINT BE$" [201] CAN'T FIND":COMP=0:GOTO 700
2575 :
2580 POKE VOC,32
2590 POKE VOC+1,AD-256*INT(AD/256)
2600 POKE VOC+2,INT(AD/256)
2610 VOC=VOC+3:GOTO 1570
2615 :
2620 REM ************************
2630 REM ** HOLE BEFEHL IN BE$ **
2635 REM ************************
2637 :
2640 IF ZE$="" THEN GOSUB 2750
2650 IF LEFT$(ZE$,1)=" "THEN ZE$=MID$(ZE$,2):GOTO 2650
2660 BE$="":FOR I=1 TO LEN(ZE$)
2670 IF LEFT$(ZE$,1)=" " THEN 2710
2680 BE$=BE$+LEFT$(ZE$,1)
2690 ZE$=MID$(ZE$,2)
2700 NEXT I
2710 RETURN
2720 :
2730 REM *************************
2740 REM *** HOLE ZEILE IN ZE$ ***
2750 REM *************************
2755 :
2760 IF BLOCK=1 THEN 2880
2770 IF COMP=0 THEN PRINT"  OK."
2780 SYS 42336
2790 ZE$=""
2800 FOR Z=512 TO 600
2810 A=PEEK(Z)
2820 IF A=0 THEN 2850
2830 ZE$=ZE$+CHR$(A)
2840 NEXT Z
2850 IF LEFT$(ZE$,1)=" "THEN ZE$=MID$(ZE$,2):GOTO 2850
2860 IF ZE$="" THEN 2770
2870 RETURN
2880 ZE$=SC$(Z1):PRINT RIGHT$(STR$(Z1),2);":";ZE$
2890 IF LEN(ZE$)<2 THEN ZE$="(  )"
2900 Z1=Z1+1
2910 IF Z1=24 THEN BLOCK=0
2920 RETURN
2980 :
2990 REM **************************
3000 REM **   WANDELE ZAHL UM    **
3010 REM **        IN XX         **
3020 REM **************************
3030 :
3040 OK=1:X=1
3050 IF LEFT$(BE$,1)="-" AND VAL(BE$)<0 THEN BE$=MID$(BE$,2):X=-1:GOTO 3080
3060 IF LEFT$(BE$,1)>="0" AND LEFT$(BE$,1)<="9" THEN 3080
3070 OK=0:RETURN
3080 XX=VAL(BE$)*X
3090 IF XX<0 THEN XX=(256*256)+XX
3100 RETURN
3103 :
3105 REM *************************
3110 REM *****  LADE SCREEN  *****
3115 REM *************************
3118 :
3120 OPEN1,8,15
3130 OPEN 2,8,2,"SCR"+STR$(SC)+",S,R"
3140 INPUT#1,A
3150 IF A<>0 THEN CLOSE2:CLOSE1:FOR I=0TO24:SC$(I)="":NEXT I:RETURN
3160 FOR ZE=0 TO 24:B$=""
3170 POKE251,2:SYS830
3180 FOR I=512 TO 600:X=PEEK(I):IF X THEN B$=B$+CHR$(X):NEXT I
3190 SC$(ZE)=B$
3200 NEXT ZE
3210 CLOSE2:CLOSE1:RETURN
3213 :
3215 REM **************************
3220 REM *****  SAVE  SCREEN  *****
3225 REM **************************
3228 :
3230 OPEN 1,8,2,"@:SCR"+STR$(SC)+",S,W"
3240 FOR ZE=0 TO 24
3250 PRINT#1,SC$(ZE)
3260 NEXT ZE
3270 CLOSE1:ZE$="":PRINT"[147]";:RETURN
3273 :
3275 REM ***********************
3280 REM **** EDIT A SCREEN ****
3285 REM ***********************
3288 :
3290 GOSUB 3400
3300 PRINT"";:COMP=1
3310 GOSUB 2750
3315 IF LEFT$(ZE$,1)="N" THEN GOSUB2630:GOSUB2630:SC=VAL(BE$):GOSUB3420:GOTO3300
3320 IF LEFT$(ZE$,1)="E" THEN ZE$="":COMP=0:GOTO 3220
3321 IF LEFT$(ZE$,1)<>"I" THEN 3330
3322 GOSUB 2630:GOSUB 2630:Z=VAL(BE$):IF Z<0 OR Z>23 THEN GOSUB 3420:GOTO 3300
3323 GOSUB 2630:A=VAL(BE$):IF A<0 OR A>23 THEN GOSUB 3420:GOTO 3300
3324 FOR I=22-A TO Z STEP-1:SC$(I+A)=SC$(I):SC$(I)="":NEXT
3325 GOSUB 3420:GOTO 3300
3330 IF LEFT$(ZE$,1)="S" THEN ZE$="":PRINT"[147]";:COMP=0:RETURN
3331 IF LEFT$(ZE$,1)<>"D" THEN 3337
3332 GOSUB 2630:GOSUB 2630:Z=VAL(BE$):IF Z<0 OR Z>23 THEN GOSUB3420:GOTO 3300
3333 GOSUB 2630:A=VAL(BE$):IF A<0 OR A>23 THEN GOSUB 3420:GOTO 3300
3334 FOR I=Z TO 22-A:SC$(I)=SC$(I+A):SC$(I+A)="":NEXT
3335 GOSUB 3420:GOTO 3300
3337 IF LEFT$(ZE$,1)="L" THEN GOSUB 3420:GOTO 3300
3340 ZE=VAL(ZE$)
3350 ZE$=MID$(ZE$,3)
3360 IF ZE>9 THEN ZE$=MID$(ZE$,2)
3370 SC$(ZE)=ZE$
3380 GOSUB 2630:IF BE$="-->" THEN GOTO 3220
3390 GOTO 3310
3393 :
3395 REM *************************
3400 REM *****  LIST SCREEN  *****
3405 REM *************************
3408 :
3410 GOSUB 3110
3420 PRINT"[147]";
3430 FOR ZE=0 TO 23
3440 PRINT RIGHT$(STR$(ZE),2);":";
3450 PRINT LEFT$(SC$(ZE),38)
3460 NEXT ZE:RETURN
3463 :
3465 REM ***********************
3470 REM ** HOLE WERT VOM TOS **
3475 REM ***********************
3480 AD=52992+PEEK(2)
3490 X=PEEK(AD-1)+256*PEEK(AD-2)
3500 POKE 2,PEEK(2)-2:RETURN
3503 :
3505 REM ***********************
3510 REM ***   SAVE-SYSTEM   ***
3515 REM ***********************
3518 :
3520 GOSUB 2630
3530 OPEN1,8,15,"S:"+BE$+".*":CLOSE1
3540 OPEN2,8,2,BE$+".VOC,P,W"
3550 PRINT#2,AN:PRINT#2,VOC
3560 FOR ZE=39 TO AN
3570 PRINT#2,WO$(ZE)
3580 PRINT#2,AD(ZE)
3590 NEXT ZE
3600 CLOSE 2:BE$=BE$+".CODE"
3610 POKE 187,FN L(720):POKE 188,FN H(720)
3620 FOR I=1 TO LEN(BE$)
3630 POKE 719+I,ASC(MID$(BE$,I,1))
3640 NEXT I:POKE 183,LEN(BE$)
3650 POKE 186,8:POKE 185,1
3660 POKE 251,FN L(BE):POKE 252,FN H(BE)
3670 POKE 780,251
3680 POKE 781,FN L(VOC)
3690 POKE 782,FN H(VOC)
3700 SYS 216+256*255
3710 GOTO 700
3713 :
3715 REM ***************************
3720 REM ****    LOAD SYSTEM    ****
3725 REM ***************************
3728 :
3730 GOSUB 2630
3740 OPEN 2,8,2,BE$+".VOC,P,R"
3750 INPUT#2,AN,VOC
3760 FOR ZE=39 TO AN
3770 INPUT#2,WO$(ZE)
3780 INPUT#2,AD(ZE)
3790 NEXT ZE:CLOSE 2
3800 SYS 50139,BE$+".CODE",8
3810 GOTO 700
3813 :
3815 REM ***************************
3820 REM ***        DATA         ***
3825 REM ***************************
3828 :
3830 DATA166,251, 32,198,255,160,  0, 32,207,255,201, 13,240,  7,153,  0
3840 DATA  2,200, 76, 69,  3,169,  0,153,  0,  2, 76,204,255
3850 FOR I= 830TO 858:READ A:POKE I,A:Z=Z+A:NEXT I
3860 IF Z<>3379 THEN PRINT"[198]EHLER IN [196]ATA[146]":END
3870 RETURN