home *** CD-ROM | disk | FTP | other *** search
/ 64'er 1985 August / 64er_Magazin_85-08_1985_Markt__Technik_de.d64 / compiler (.txt) < prev    next >
Commodore BASIC  |  2022-10-26  |  11KB  |  480 lines
  1. 100 rem ****************************
  2. 110 rem *                          *
  3. 120 rem *       forth-compiler     *
  4. 130 rem *                          *
  5. 140 rem *           fuer           *
  6. 150 rem *                          *
  7. 160 rem *        commodore-64      *
  8. 170 rem *                          *
  9. 180 rem ****************************
  10. 190 rem *                          *
  11. 200 rem *  alexander schindowski   *
  12. 210 rem *                          *
  13. 220 rem *  6000 frankfurt/main 50  *
  14. 230 rem *                          *
  15. 240 rem * rudolf-hilferding-str.49 *
  16. 250 rem *                          *
  17. 260 rem ****************************
  18. 270 rem *                          *
  19. 280 rem *  telephon:(069)/570520   *
  20. 290 rem *                          *
  21. 300 rem ****************************
  22. 310 :
  23. 320 :
  24. 330 :
  25. 340 if a=0 thena=1:load"vocabulary",8,1
  26. 350 def fnh(x)=(int(x/256))
  27. 360 def fnl(x)=(x-256*fnh(x))
  28. 370 poke 53272,23:print"[147][154]";chr$(8);
  29. 380 voc=6*4096:be=voc:sp=0:z1=0
  30. 390 poke 55,fn l(be):poke 56,fn h(be)
  31. 395 dim st(20),sc$(24),wo$(100),ad(100)
  32. 400 print tab(14);"[198]orth-[195]ompiler"
  33. 410 print tab(17);"fuer den"
  34. 420 print tab(15);"[195]ommodore-64"
  35. 430 print"----------------------------------------";
  36. 440 print"     [214]on [193]lexander [211]chindowski 1985"
  37. 450 data 38
  38. 460 data "+",49563
  39. 470 data "cls",49158,"depth",49968
  40. 480 data "@",50012,"drop",49236
  41. 490 data "emit",49855,"expect",49936
  42. 500 data "=",49410,"i",49766
  43. 510 data "key",49880
  44. 520 data "+loop",49821,"mod",49733
  45. 530 data "not",49458,"over",49284
  46. 540 data ".",49163,"-",49578
  47. 550 data "swap",49248,">r",49751
  48. 560 data "and",49497,"cr",49384
  49. 570 data "/",49721,"do",49757,"!",49977
  50. 580 data "dup",49239,"xor",49541
  51. 590 data "get",49862,">",49434
  52. 600 data "<",49452,"loop",49811
  53. 610 data "*",49596,"or",49519
  54. 620 data "c@",50030,"c!",49996
  55. 630 data "r>",49745,"type",49915
  56. 640 data "pick",50062,"call",50047,"rot",50085
  57. 650 read an
  58. 660 for i=1 to an
  59. 670 read wo$(i),ad(i)
  60. 680 next i:poke 2,0:poke 252,0
  61. 690 gosub 3830
  62. 693 :
  63. 695 rem **************************
  64. 700 rem *** befehls-auswertung ***
  65. 705 rem **************************
  66. 708 :
  67. 710 gosub 2630
  68. 715 :
  69. 720 if be$=":" then 1540
  70. 725 :
  71. 730 for i=an to 1 step -1
  72. 740 if be$=wo$(i) then 760
  73. 750 next i:goto 770
  74. 760 sys ad(i):goto 700
  75. 765 :
  76. 770 gosub 3030
  77. 780 if ok=0 then 830
  78. 790 poke 781,fn l(xx)
  79. 800 poke 780,fn h(xx)
  80. 810 sys 49194
  81. 820 goto 700
  82. 825 :
  83. 830 if be$="reset" then run
  84. 835 :
  85. 840 if be$="basic" then end
  86. 845 :
  87. 850 if be$<>"vlist" then 900
  88. 860 print:for i=an to 1 step-1
  89. 870 print wo$(i)"  ";
  90. 880 next:print
  91. 890 goto 700
  92. 895 :
  93. 900 if be$<>"forget" then 950
  94. 910 gosub 2630:for i=an to 1 step-1
  95. 920 if be$<>wo$(i) then next i
  96. 930 if i>an then print be$" [201] can't find":goto 700
  97. 935 :
  98. 940 voc=ad(i):an=i-1:goto 700
  99. 950 if be$<>"(" then 980
  100. 960 if be$<>")" then gosub2630:goto960
  101. 970 goto 700
  102. 975 :
  103. 980 if be$<>"edit" then 1020
  104. 990 gosub 2630 :sc=val(be$)
  105. 1000 print"[211]creen:";sc:gosub 3280
  106. 1010 if be$="-->"then ze$="":sc=sc+1:goto1000
  107. 1012 goto 700
  108. 1015 :
  109. 1020 if be$<>"load" then 1050
  110. 1030 gosub 2630:sc=val(be$)
  111. 1040 block=1:z1=0:gosub 3110:goto 700
  112. 1050 if be$<>"-->" then 1070
  113. 1060 sc=sc+1:gosub3110:comp=1:block=1:z1=0:goto 700
  114. 1070 :
  115. 1080 if be$<>"variable" then 1145
  116. 1085 gosub 2630:an=an+1:wo$(an)=be$
  117. 1090 ad(an)=voc:xx=voc+8
  118. 1095 gosub 3470:poke voc,169
  119. 1100 poke voc+1,fn h(xx)
  120. 1105 poke voc+2,162
  121. 1110 poke voc+3,fn l(xx)
  122. 1115 poke voc+4,32:poke voc+5,42
  123. 1120 poke voc+6,192:poke voc+7,96
  124. 1125 poke voc+8,fn l(x)
  125. 1130 poke voc+9,fn h(x)
  126. 1135 voc=voc+10
  127. 1140 goto 700
  128. 1145 :
  129. 1150 if be$<>"memory" then 1220
  130. 1155 gosub 2630:an=an+1:wo$(an)=be$
  131. 1160 ad(an)=voc
  132. 1165 gosub 3470:poke voc,169
  133. 1170 poke voc+1,fn h(voc+12)
  134. 1175 poke voc+2,162
  135. 1180 poke voc+3,fn l(voc+12)
  136. 1185 poke voc+4,32:poke voc+5,42
  137. 1190 poke voc+6,192:ad=voc+12+xx
  138. 1195 poke voc+7,96
  139. 1200 poke voc+8,fn l(ad):poke voc+9,fn h(ad)
  140. 1205 poke voc+10,fn l(xx):poke voc+11,fn h(xx)
  141. 1210 voc=ad:goto 700
  142. 1220 :
  143. 1230 if be$<>"constant" then 1280
  144. 1240 gosub 2630:a$=": "+be$+" "
  145. 1250 gosub 3470
  146. 1260 ze$=a$+str$(x)+" ;"+ze$
  147. 1270 goto 700
  148. 1280 :
  149. 1290 if be$<>"clear" then 1350
  150. 1300 gosub 2630:sc=val(be$)
  151. 1310 for ze=0 to 24
  152. 1320 sc$(ze)=""
  153. 1330 next ze:gosub3220
  154. 1340 goto700
  155. 1350 :
  156. 1360 ifbe$="save-system"then3510
  157. 1365 :
  158. 1370 ifbe$="load-system"then3720
  159. 1380 :
  160. 1390 if be$<>"floppy" then 1420
  161. 1400 gosub2630
  162. 1410 open1,8,15,be$:close1:goto 700
  163. 1420 :
  164. 1430 ifbe$<>"list" then 1520
  165. 1440 gosub2630:sc=val(be$):gosub3110
  166. 1450 input"[193]uf [196]rucker (y/n)";a$:a=3:ifa$="y"thena=4
  167. 1460 open4,a,-7*(a=4)
  168. 1470 for z=0 to 23
  169. 1480 print#4,right$(str$(z),2)":"sc$(z)
  170. 1490 next z:close4
  171. 1500 ifa=3thenpoke198,0:wait198,1
  172. 1510 comp=0:goto700
  173. 1520 :
  174. 1530 printbe$" [201] can't find":goto 700
  175. 1533 :
  176. 1535 rem *************************
  177. 1540 rem ***     compiler      ***
  178. 1545 rem *************************
  179. 1548 :
  180. 1550 gosub2630:an=an+1:wo$(an)=be$
  181. 1560 ad(an)=voc:comp=1
  182. 1570 :
  183. 1580 gosub 2630
  184. 1590 for i=1 to anz
  185. 1600 if be$<>wo$(i) then next i
  186. 1610 ad=ad(i)
  187. 1615 :
  188. 1620 if be$<>"begin" then 1640
  189. 1630 st(sp)=voc:sp=sp+1:goto 1570
  190. 1635 :
  191. 1640 if be$<>"until" then 1730
  192. 1650 poke voc,32
  193. 1660 poke voc+1,180:poke voc+2,194
  194. 1670 poke voc+3,176:poke voc+4,3
  195. 1680 poke voc+5,76
  196. 1690 sp=sp-1:ad=st(sp):if sp<0 then65535
  197. 1700 poke voc+6,fn l(ad)
  198. 1710 poke voc+7,fn h(ad)
  199. 1720 voc=voc+8:goto 1570
  200. 1725 :
  201. 1730 if be$=";" then poke voc,96:voc=voc+1:comp=0:goto 700
  202. 1735 :
  203. 1740 gosub 3030
  204. 1750 if ok=0 then 1800
  205. 1760 poke voc,169:poke voc+1,fn h(xx)
  206. 1770 pokevoc+2,162:pokevoc+3,fn l(xx)
  207. 1780 poke voc+4,32:poke voc+5,42
  208. 1790 poke voc+6,192:voc=voc+7:goto 1570
  209. 1800 :
  210. 1810 if be$<>"if" then 1870
  211. 1820 poke voc,32:poke voc+1,180
  212. 1830 poke voc+2,194:poke voc+3,176
  213. 1840 poke voc+4,3:poke voc+5,76
  214. 1850 st(sp)=voc+6:sp=sp+1
  215. 1860 voc=voc+8:goto 1570
  216. 1870 :
  217. 1880 if be$<>"endif" then 1930
  218. 1890 sp=sp-1:ad=st(sp)
  219. 1900 poke ad,fn l(voc)
  220. 1910 poke ad+1,fn h(voc)
  221. 1920 goto 1570
  222. 1930 :
  223. 1940 if be$<>"else" then 2010
  224. 1950 ad=st(sp-1)
  225. 1960 st(sp-1)=voc+1
  226. 1970 poke voc,76:voc=voc+3
  227. 1980 poke ad,fn l(voc)
  228. 1990 poke ad+1,fn h(voc)
  229. 2000 goto 1570
  230. 2010 :
  231. 2020 if be$="while" then 1820
  232. 2030 :
  233. 2040 if be$<>"repeat" then 2110
  234. 2050 ad=st(sp-1):a2=st(sp-2)
  235. 2060 sp=sp-1
  236. 2070 poke voc,76
  237. 2080 poke voc+1,fn l(a2)
  238. 2090 poke voc+2,fn h(a2)
  239. 2100 voc=voc+3:goto 1980
  240. 2110 :
  241. 2120 if be$<>"."+chr$(34) then 2225
  242. 2125 a$="":ze$=mid$(ze$,2)
  243. 2130 if left$(ze$,1)<>chr$(34) then a$=a$+left$(ze$,1):ze$=mid$(ze$,2):goto2130
  244. 2135 ze$=mid$(ze$,2):a$=a$+chr$(0)
  245. 2140 ad=voc+10
  246. 2145 poke voc,169
  247. 2150 poke voc+1,fn h(ad)
  248. 2155 poke voc+2,162
  249. 2160 poke voc+3,fn l(ad)
  250. 2165 poke voc+4,32:poke voc+5,234
  251. 2170 poke voc+6,194:poke voc+7,76
  252. 2175 ad=voc+10+len(a$)
  253. 2180 poke voc+8,fn l(ad)
  254. 2185 poke voc+9,fn h(ad)
  255. 2190 voc=voc+10
  256. 2200 for i=0 to len(a$)-1
  257. 2205 poke voc+i,asc(mid$(a$,i+1,1))
  258. 2210 if left$(ze$,1)=" " then ze$=mid$(ze$,2):goto 2210
  259. 2215 next i
  260. 2220 voc=ad:goto 1570
  261. 2225 :
  262. 2230 if be$<>"text"+chr$(34) then2320
  263. 2235 a$="":ze$=mid$(ze$,2)
  264. 2240 if left$(ze$,1)<>chr$(34) then a$=a$+left$(ze$,1):ze$=mid$(ze$,2):goto2240
  265. 2245 ze$=mid$(ze$,2):a$=a$+chr$(0)
  266. 2250 ad=voc+10
  267. 2255 poke voc,169
  268. 2260 poke voc+1,fn h(ad)
  269. 2265 poke voc+2,162
  270. 2270 poke voc+3,fn l(ad)
  271. 2273 poke voc+4,32:poke voc+5,42:poke voc+6,192
  272. 2275 poke voc+7,76
  273. 2280 ad=voc+10+len(a$)
  274. 2285 poke voc+8,fn l(ad)
  275. 2290 poke voc+9,fn h(ad)
  276. 2295 voc=voc+10
  277. 2300 for i=0 to len(a$)-1
  278. 2305 poke voc+i,asc(mid$(a$,i+1,1)):next
  279. 2310 if left$(ze$,1)=" " then ze$=mid$(ze$,2):goto 2310
  280. 2315 voc=ad:goto 1570
  281. 2320 :
  282. 2330 if be$<>"do" then 2390
  283. 2340 poke voc,32
  284. 2350 poke voc+1,fn l(ad)
  285. 2360 poke voc+2,fn h(ad)
  286. 2370 voc=voc+3:st(sp)=voc
  287. 2380 sp=sp+1:goto 1570
  288. 2390 :
  289. 2400 if be$<>"loop" and be$<>"+loop" then 2500
  290. 2410 poke voc,32
  291. 2420 poke voc+1,fn l(ad)
  292. 2430 poke voc+2,fn h(ad)
  293. 2440 poke voc+3,176:poke voc+4,3
  294. 2450 sp=sp-1:ad=st(sp)
  295. 2460 poke voc+5,76
  296. 2470 poke voc+6,ad-256*int(ad/256)
  297. 2480 poke voc+7,int(ad/256)
  298. 2490 voc=voc+8:goto 1570
  299. 2500 :
  300. 2510 if be$<>"(" then 2540
  301. 2520 gosub 2630:if be$<>")" then 2520
  302. 2530 goto 1570
  303. 2540 :
  304. 2550 if be$=";s" then poke voc,96:voc=voc+1:goto 1570
  305. 2560 :
  306. 2570 if i>an then print be$" [201] can't find":comp=0:goto 700
  307. 2575 :
  308. 2580 poke voc,32
  309. 2590 poke voc+1,ad-256*int(ad/256)
  310. 2600 poke voc+2,int(ad/256)
  311. 2610 voc=voc+3:goto 1570
  312. 2615 :
  313. 2620 rem ************************
  314. 2630 rem ** hole befehl in be$ **
  315. 2635 rem ************************
  316. 2637 :
  317. 2640 if ze$="" then gosub 2750
  318. 2650 if left$(ze$,1)=" "then ze$=mid$(ze$,2):goto 2650
  319. 2660 be$="":for i=1 to len(ze$)
  320. 2670 if left$(ze$,1)=" " then 2710
  321. 2680 be$=be$+left$(ze$,1)
  322. 2690 ze$=mid$(ze$,2)
  323. 2700 next i
  324. 2710 return
  325. 2720 :
  326. 2730 rem *************************
  327. 2740 rem *** hole zeile in ze$ ***
  328. 2750 rem *************************
  329. 2755 :
  330. 2760 if block=1 then 2880
  331. 2770 if comp=0 then print"  ok."
  332. 2780 sys 42336
  333. 2790 ze$=""
  334. 2800 for z=512 to 600
  335. 2810 a=peek(z)
  336. 2820 if a=0 then 2850
  337. 2830 ze$=ze$+chr$(a)
  338. 2840 next z
  339. 2850 if left$(ze$,1)=" "then ze$=mid$(ze$,2):goto 2850
  340. 2860 if ze$="" then 2770
  341. 2870 return
  342. 2880 ze$=sc$(z1):print right$(str$(z1),2);":";ze$
  343. 2890 if len(ze$)<2 then ze$="(  )"
  344. 2900 z1=z1+1
  345. 2910 if z1=24 then block=0
  346. 2920 return
  347. 2980 :
  348. 2990 rem **************************
  349. 3000 rem **   wandele zahl um    **
  350. 3010 rem **        in xx         **
  351. 3020 rem **************************
  352. 3030 :
  353. 3040 ok=1:x=1
  354. 3050 if left$(be$,1)="-" and val(be$)<0 then be$=mid$(be$,2):x=-1:goto 3080
  355. 3060 if left$(be$,1)>="0" and left$(be$,1)<="9" then 3080
  356. 3070 ok=0:return
  357. 3080 xx=val(be$)*x
  358. 3090 if xx<0 then xx=(256*256)+xx
  359. 3100 return
  360. 3103 :
  361. 3105 rem *************************
  362. 3110 rem *****  lade screen  *****
  363. 3115 rem *************************
  364. 3118 :
  365. 3120 open1,8,15
  366. 3130 open 2,8,2,"scr"+str$(sc)+",s,r"
  367. 3140 input#1,a
  368. 3150 if a<>0 then close2:close1:for i=0to24:sc$(i)="":next i:return
  369. 3160 for ze=0 to 24:b$=""
  370. 3170 poke251,2:sys830
  371. 3180 for i=512 to 600:x=peek(i):if x then b$=b$+chr$(x):next i
  372. 3190 sc$(ze)=b$
  373. 3200 next ze
  374. 3210 close2:close1:return
  375. 3213 :
  376. 3215 rem **************************
  377. 3220 rem *****  save  screen  *****
  378. 3225 rem **************************
  379. 3228 :
  380. 3230 open 1,8,2,"@:scr"+str$(sc)+",s,w"
  381. 3240 for ze=0 to 24
  382. 3250 print#1,sc$(ze)
  383. 3260 next ze
  384. 3270 close1:ze$="":print"[147]";:return
  385. 3273 :
  386. 3275 rem ***********************
  387. 3280 rem **** edit a screen ****
  388. 3285 rem ***********************
  389. 3288 :
  390. 3290 gosub 3400
  391. 3300 print"";:comp=1
  392. 3310 gosub 2750
  393. 3315 if left$(ze$,1)="n" then gosub2630:gosub2630:sc=val(be$):gosub3420:goto3300
  394. 3320 if left$(ze$,1)="e" then ze$="":comp=0:goto 3220
  395. 3321 if left$(ze$,1)<>"i" then 3330
  396. 3322 gosub 2630:gosub 2630:z=val(be$):if z<0 or z>23 then gosub 3420:goto 3300
  397. 3323 gosub 2630:a=val(be$):if a<0 or a>23 then gosub 3420:goto 3300
  398. 3324 for i=22-a to z step-1:sc$(i+a)=sc$(i):sc$(i)="":next
  399. 3325 gosub 3420:goto 3300
  400. 3330 if left$(ze$,1)="s" then ze$="":print"[147]";:comp=0:return
  401. 3331 if left$(ze$,1)<>"d" then 3337
  402. 3332 gosub 2630:gosub 2630:z=val(be$):if z<0 or z>23 then gosub3420:goto 3300
  403. 3333 gosub 2630:a=val(be$):if a<0 or a>23 then gosub 3420:goto 3300
  404. 3334 for i=z to 22-a:sc$(i)=sc$(i+a):sc$(i+a)="":next
  405. 3335 gosub 3420:goto 3300
  406. 3337 if left$(ze$,1)="l" then gosub 3420:goto 3300
  407. 3340 ze=val(ze$)
  408. 3350 ze$=mid$(ze$,3)
  409. 3360 if ze>9 then ze$=mid$(ze$,2)
  410. 3370 sc$(ze)=ze$
  411. 3380 gosub 2630:if be$="-->" then goto 3220
  412. 3390 goto 3310
  413. 3393 :
  414. 3395 rem *************************
  415. 3400 rem *****  list screen  *****
  416. 3405 rem *************************
  417. 3408 :
  418. 3410 gosub 3110
  419. 3420 print"[147]";
  420. 3430 for ze=0 to 23
  421. 3440 print right$(str$(ze),2);":";
  422. 3450 print left$(sc$(ze),38)
  423. 3460 next ze:return
  424. 3463 :
  425. 3465 rem ***********************
  426. 3470 rem ** hole wert vom tos **
  427. 3475 rem ***********************
  428. 3480 ad=52992+peek(2)
  429. 3490 x=peek(ad-1)+256*peek(ad-2)
  430. 3500 poke 2,peek(2)-2:return
  431. 3503 :
  432. 3505 rem ***********************
  433. 3510 rem ***   save-system   ***
  434. 3515 rem ***********************
  435. 3518 :
  436. 3520 gosub 2630
  437. 3530 open1,8,15,"s:"+be$+".*":close1
  438. 3540 open2,8,2,be$+".voc,p,w"
  439. 3550 print#2,an:print#2,voc
  440. 3560 for ze=39 to an
  441. 3570 print#2,wo$(ze)
  442. 3580 print#2,ad(ze)
  443. 3590 next ze
  444. 3600 close 2:be$=be$+".code"
  445. 3610 poke 187,fn l(720):poke 188,fn h(720)
  446. 3620 for i=1 to len(be$)
  447. 3630 poke 719+i,asc(mid$(be$,i,1))
  448. 3640 next i:poke 183,len(be$)
  449. 3650 poke 186,8:poke 185,1
  450. 3660 poke 251,fn l(be):poke 252,fn h(be)
  451. 3670 poke 780,251
  452. 3680 poke 781,fn l(voc)
  453. 3690 poke 782,fn h(voc)
  454. 3700 sys 216+256*255
  455. 3710 goto 700
  456. 3713 :
  457. 3715 rem ***************************
  458. 3720 rem ****    load system    ****
  459. 3725 rem ***************************
  460. 3728 :
  461. 3730 gosub 2630
  462. 3740 open 2,8,2,be$+".voc,p,r"
  463. 3750 input#2,an,voc
  464. 3760 for ze=39 to an
  465. 3770 input#2,wo$(ze)
  466. 3780 input#2,ad(ze)
  467. 3790 next ze:close 2
  468. 3800 sys 50139,be$+".code",8
  469. 3810 goto 700
  470. 3813 :
  471. 3815 rem ***************************
  472. 3820 rem ***        data         ***
  473. 3825 rem ***************************
  474. 3828 :
  475. 3830 data166,251, 32,198,255,160,  0, 32,207,255,201, 13,240,  7,153,  0
  476. 3840 data  2,200, 76, 69,  3,169,  0,153,  0,  2, 76,204,255
  477. 3850 for i= 830to 858:read a:poke i,a:z=z+a:next i
  478. 3860 if z<>3379 then print"[198]ehler in [196]ata[146]":end
  479. 3870 return
  480.