From 723127b51e3cf66da0d5066174a55cf222173901 Mon Sep 17 00:00:00 2001 From: Carsten Strotmann Date: Sun, 11 Apr 2021 13:54:55 +0200 Subject: [PATCH 01/21] blkpack and blkunpack tools from collapseos --- tools/blkpack.c | 97 +++++++++++++++++++++++++++++++++++++++++++++++ tools/blkunpack.c | 64 +++++++++++++++++++++++++++++++ 2 files changed, 161 insertions(+) create mode 100644 tools/blkpack.c create mode 100644 tools/blkunpack.c diff --git a/tools/blkpack.c b/tools/blkpack.c new file mode 100644 index 0000000..9ce3dfa --- /dev/null +++ b/tools/blkpack.c @@ -0,0 +1,97 @@ +#include +#include +#include +#include +#include +#include +#include + +static int lineno; + +static void emptylines(int n) +{ + for (int i=0; i<64*n; i++) putchar(0x20); +} + +static int getmarker(char *line) // returns -1 on error, blkid otherwise +{ + int blkid; + int r = sscanf(line, "( ----- %d )\n", &blkid); + if (r == 1) { + return blkid; + } else { + return -1; + } +} + +static int expectmarker(char *line) +{ + int blkid = getmarker(line); + if (blkid < 0) { // could not scan + fprintf( + stderr, "Error at line %d: expecting block marker\n", lineno); + } + return blkid; +} + +static void usage() +{ + fprintf(stderr, "Usage: blkpack < blk.fs > blkfs\n"); +} + +int main(int argc, char *argv[]) +{ + int prevblkid = -1; + int blkid; + char *line = NULL; + if (argc != 1) { + usage(); + return 1; + } + lineno = 1; + size_t n = 0; + ssize_t cnt = getline(&line, &n, stdin); + if (cnt <= 0) { + fprintf(stderr, "No input\n"); + return 1; + } + while (1) { + blkid = expectmarker(line); + if (blkid < 0) return 1; + if (blkid <= prevblkid) { + fprintf( + stderr, + "Wrong blkid (%d) at line %d: blocks must be ordered\n", + blkid, lineno); + return 1; + } + emptylines((blkid-prevblkid-1)*16); + int blkline; + for (blkline=0; blkline<16; blkline++) { + lineno++; + cnt = getline(&line, &n, stdin); + if (cnt <= 0) break; // EOF + if (cnt > 65) { + fprintf(stderr, "Line %d too long (blk %d)\n", lineno, blkid); + return 1; + } + if (getmarker(line) >= 0) break; // we have a marker early + line[cnt-1] = '\0'; // remove newline + printf("%s", line); + // pad line to 64 chars + for (int i=cnt-1; i<64; i++) putchar(0x20); + } + if (blkline == 16) { + lineno++; + cnt = getline(&line, &n, stdin); + } else { + // fill to 16 lines + emptylines(16-blkline); + } + if (cnt <= 0) break; // EOF + prevblkid = blkid; + } + free(line); + return 0; +} + diff --git a/tools/blkunpack.c b/tools/blkunpack.c new file mode 100644 index 0000000..a17b841 --- /dev/null +++ b/tools/blkunpack.c @@ -0,0 +1,64 @@ +#include +#include +#include + +/* Unpacks blkfs into its source form. + * + * If numerical "startat" is specified, blkno start at this number. + * + * Whitespaces at the right of every line are trimmed. + */ +void usage() +{ + fprintf(stderr, "Usage: blkunpack [startat] < blkfs > blk.fs\n"); +} + +int main(int argc, char *argv[]) +{ + char buf[1024]; + int blkid = 0; + if (argc > 2) { + usage(); + return 1; + } + if (argc == 2) { + blkid = strtol(argv[1], NULL, 10); + } + while (fread(buf, 1024, 1, stdin) == 1) { + int linecnt = 0 ; + for (int i=1023; i>=0; i--) { + if (buf[i] > ' ') { + linecnt = (i / 64) + 1; + break; + } + } + if (linecnt) { + // not an empty block + printf("( ----- %03d )\n", blkid); + for (int i=0; i=0; j--) { + if (line[j] > ' ') { + break; + } + } + int len = j+1; + if (len) { + for (; j>=0; j--) { + if (line[j] == '\0') { + line[j] = ' '; + } + } + fwrite(line, len, 1, stdout); + } + fputc('\n', stdout); + } + } + blkid++; + } + return 0; +} From 761877096145c8b2b57de16d0f0b4cc6728e0cd0 Mon Sep 17 00:00:00 2001 From: Carsten Strotmann Date: Sun, 11 Apr 2021 13:58:06 +0200 Subject: [PATCH 02/21] Removed old kernel.org (could be confused with an Org-Mode file) --- 8086/msdos/kernel.org | Bin 15874 -> 0 bytes 1 file changed, 0 insertions(+), 0 deletions(-) delete mode 100644 8086/msdos/kernel.org diff --git a/8086/msdos/kernel.org b/8086/msdos/kernel.org deleted file mode 100644 index 4c30e9f6e7a3fb75da43b4c69198136065b1ff3e..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 15874 zcmdsed3@7V_UJd?JxQCirCVCkCS7Pt(sZGerE8jnhNekK8rqZ*1ZkxREz<>MlkF-? z5EVs69dvv$zHxWvS2{Y*AhK!|3(TN^hyugfajeCG5s`dw38o{LF`F5ik!)U_|KeYyN1T}4qU>W@XgFWhRR zs71w^G6VJh`+pacQWkeCxUb9U^*7Y!PaJ3HY*}nEjI&HEvXm5YM5R!A98C@RZkMO- zV$$(RJSm|Czr*I8?(knss;k>DVdm@GBH0u*i@t#$Gw6BrP5hWk^TbKB9S0@T&IZgZFOC^wpY1;04R~IFa$7tT`bOsy^@9H!Hd4^_dtO3Wnx)_1{4luz6 zUl1^H0_mkWmq%*E3uF%+0Y%_xL8Icr0 z2Vb=tsE#418bEdg8D}x!D-u-zK#dGz4^($D{!J&5sue)<8Lp-v;F!{?i=mWc1;hA# z)lUGMzaqgBMoGd5GQPxwPfBc_0nl^Ino9rM3`jXig1ru~-!p6cl^;XLB%2MpzR#%0 zeunl}e}yoF90SM+<{`h`@AdtQk*O{MY>;6cO|Ax!4Ns7PHvt%7_@Kw*2mn|`;#sZ= zNldKzXmihTWEKNpBg+?7Al!!V?%jhI)MO$nIGP-`V1uKH4c};vWUGmr6?_gq=u!QB z2ntt3vZKf>mbO(dgZ9RRJ_;F@uu-HNfX2rF*tDLL7WNPTH?V@O!8>J&+wlrw3T4bQ zfO(E(oo<)!efHsD#&ZC9RPJ{IKwq$QakWJk;yQ!@ z*2xX9dH@aq&}h-^;?A%g!WjT*2*=STV>$xaD4c-XUY%5J8nHC z4|NU5Zg3oMb-PU?bhnzr-?`nxJ2oUVKZRrH`BB8kbHykIFCS`}HO=2BiNXp92Ov;l z^LV>m+SFzM&g9u*5XW*pe9Iphk32d6+6AO2k0*G4_*SHc4+mL9J;cY84LsxVHoV4P zKZ=mw0AvTxSUvV#d{gFO1pNU(eLU^;ALg6X5@bI>KIEAuum2q1G)@A2#wU=^d4=ga zzKM|lR{-!&p7%JWSQ{KF;rdBrbrXOQUXh<7G@15D>xdB&NxUG~Wx8VF`q8HA$2%1@ zJ|xco4%9t`d@nO`wZRvxORLPltB1Ko^^SDbx&pokZpf^f=QB z`2IGDEEebz(+2$BEY#EtUQZ%xplANG!c^?p3O%2Mp82l|Q?cg`pw9oJFm>wSP%?Q- zU>p2FN2@LpNhW_0IH%PefEGn1lYT)_D1RLn6h*B%1;EY=J#@XRyQ6yt4Kxu%-hu}s$FXp3$;Aku5A=; zT0NUW=7@A*#S^0X=$|O6Mmf_C>{6&!tmhTZ^pMbtghW`=Z z?*hE?q`0Md@O&!ytEecyFha9JrWp`Z$ycJH@&_cjkV>w@u$3z1xZQ&%QVFA^3(J#~ z(j1n^^jF2vBu1&I$X7O%9sX%*naa^5M=1mwT@AG^&s1eosO*C-CE!sMla*!tU044U ziD07O5DeC-anyy|CgDB`9w<^Ctx*Eqyg09#Ycw z3X85#s1?FWJ*y|r0ie838G=PO0rwR=@_$Cz!Kxl0Jk;`BYgQ4X3yY-G;&4B27#7W0j%p&fE`UEKOoH7l!CC%JpkL4Mq*Vw_xA(=)R<#<7rL2juOQxgH!$TN*10;ANKBu4#kjo<3A)fTFm5(F9n zn5|w{B}1KRbb;sPLr|*DB9qlzWxds3XVHn;Q$isqcNPh%#Y(>;;B`-TAb2&GEI7g6 zAgWExmER%9Hc^Y^KO;>Z;qauIuku-4evoalaLgFh)85tH*>g{KPiMscB4yc$pT?TATL1Ad3kVQs*PS=7~02)sLLf6&w50)v3e5H^PNMD4MA5innMm-+^bJcewD+6x+i zu*ZIc{W@wN?x96@Lz?^vRlD{z6|QRxc`Itaw7++7SAT~4DC!}%!#dsZZ4{_b`2O1- zkGzr7)H&p06cel;tB&3hx_(AdqexT^VWR2!vFQlAEWzTVb4YTuVys1{j4t8yYz{F; z)5T-0(MQgrLgYs0lF8A0u)d()Yo8t+?r(0o{_Pg2=M+HIMRO8n5n?u8C_dlxfa?19 zGJa0<_3t4t7_McG41S$QTBBLy@eEKlJ?$Gjx^^GC{SS&uzx(c(QB`2*SlrUtx}f8J zJ)1`!hY1wyi9T`zC$J`ZEO|FtQDD*iD*6?e-&pc-Gy{CFjq@E#PDXQMk+VhD$LOQ` znf7ReUWum1LZ{)8PLzfV%0#C?JsTtvt%eWU@ANz+oMsxJx0CCW{?)T4lBwZr_29cb zny143vt~9A?~o#c528)PuHhwA<@^zxi}{}U)(SDkQ@3#1Gc+bLOT%LCO(PU#x4TY` za9F8%0f09`Gp9`%yksV8HJs0FwSgu+uh|SI$4p*>k--Qwe4vqo$tjJ>?9#9h z)w|DVwuELi55I!ozXABTh67K8%704uQUmHszR|F?4!=XC^@pcNA=#kDLKIrg>UMh@ z3|htXD9IAVX)PpCt1#o)J;M$OX>h15#H^)l5@<7fVFXmEWqei;vIuUiW*AQhnWkN5 z^Va*MGt|#u=-I~%uxJ(v$XqR(+2E?Vm_$(pWR;e!lp4R%{=ZH!3&^hWywixV1 zAxV#619dK+D`rdRoH*<18{M?m+8CCCpj>SssRp#o>X|2_hu`S=2|XjGkj#n^3IYv& zmuJexn5K|vPZ!G^9=Dr0A_vn;V~WXxF=DRG>T@+%-4~O}XLqKSFY8PwCq2wtoA;JK z3I9C3w|sRE{nj&kOALF9$!}tW5$exlwp{uoB1Le&ju}S=Vz{6WQjy^pP|@ads*T*G zw<7DgDQBGQF?hhqd7WQ-Am9 zb;IEYqt-`H8QyV#GlYjn^oEaBXn^9usDm732!Dobr^c3&OEIF`YqevFiSjNbvt#*y zH|R$-z6DagkF%?zs0FbD?D;V%**u#Nvkss+haMO)sO1i z$1IB-0>bq%t2rmv&$Pz$G3Zl5@cpuwEDUM&aOz9R8?mg%S`QscGIqp6t*X<46WXceQcgMd1i?y;QYAz@^_6JAqWit;vOM&N!s}Mcn)F-L9P-Hx}9xNn707 zT#JM~pt)v3$db4{2x!-?93ctES#xpJyuR30I7k!8uj6VgcOY_~*W;|e02c&;5QX!Z zUq#Eyo=Dz{tN8^WQnH6YSF!77arRoU{}$cF*bhg)!o3XZnn*6i@xSmm9Cq-i-^5wj zz0$;fh+}FUO*n4Mo3z|HZj@km*j)7(!ZwO389a$(kK*l6Flwm6z_wAGbW^meW2i<^ zz-^G)f94y-LTtTB53sw%5SPcIah^oVN2#nfTd+RphAjXQfi-nXMCe_%j(pV${R|S{ zKT5E9J&+rL6P+a-&^Sif)gnbkS=8S}o(4}T3*d2Bl0|nwqZMT#SaeSVEy5Z_^J>nd zbi$l0CgmrR*FFKqIcpKPYb8uLW}m>bjbiP8wa46Pt7LpOwnb`4z~)gHxQy%=#n^pt zG9wX)G1#k238~GN_g;q2v^T2*O z;!$PGNmaby3D(y*{2tAf+e@_eyR%Mm;Vrj3=X3#P1vBf=<}BtA`>dN1c^0j`(6x##q#UgV?2< zJQ2^!6S3&F$KS_2E*>)~szjKpMWtse$mj&tZ4ETw0jeNn2^=QGhDjAp6AkHD-5{H<( z=#3gGv6V&`^3^1QC$&OohFu#)9-Ut$sY~P#3VZ2KoXXTf7K5in4uC^kQldZ6$+=44yVnt@M8mN& zu~EEi({4=^wH(Zg1g_Y=7)n1LPlshXTkR4ljXt|ShydF++M6gV^0WGK-NI{+as zHrOQC3)hs9R&0_J1oC4uJxOS^`aR&UWR;(oghmqg8Fy_37#1troq_F7lUK$GEf2JH zb$1z_0P|)gmL##>TIZPVax@xK`YWtteiCoyFy|6{p*1*!y1eYh_I_zp4bwRk2sOLglp|%S|V0a?|_6v5U z1f+@i$Ie8QC5rKPiB_^KNt|x=yR0=B(~~4QL8&2ElUR?_S~V(pR(S6_=~TEv9qCTq zco&^{;*k(@-9a0uZaSP^cCzREBP;0eXJM%n_)U_HsFJx#*~k0<8y^CHHkw+>v*3iB zTx>G>H<3EZwemb`QGXRd`)4DzWIh-Bz_uOGG>YkembAr2?oZ}Mz#(o`vJ=!Cmh)%c z3Ua}2kHSzjUOR*%9bi6e zmhSyBj3hCQf?y~Ob=OWRbRw8*I9(n%bp-Ym#2=Q$KS}2x0UaM4Ib$JC2Z7))IElz{ zFfP%-u9nW(oh`Estvw4CAj$~@dJvd{bn4h(z~M)RL&7qh4Vi8X(tQ*o)tuXb@$YmH zw7RU|%t#WdVCatY&|+YAmIeu!0Cp4fV^uPq9*b@tB$C`cowK{<;UFLBIJ?6sk75;n z(Bag>E9gkJlSHS`(|ve^r2pt`3u9jfD^EE|Zi)aV%J1+IF8NdN9JR!k%0b+R8UD%6b^J zmOPcp!pdPd90FB87E~WhaI(bFq8@}1YRQ3A4#P7qxQI15GxdZC zvy;`LM~{xp zRdVxbh+@Da$qf-S!A1U&%H@KL>?+*cUEQU+YfW=%zD1p8P@2 zx6{Kn!2Dl*X=cv__&0nTDqe$7l7||bcczr-9n{s4p3#u$dF&`^)V9?e3K$C!EcLRm z3m_{-qXl|}s~pY4fqEHyS$+!Q{|<}5D5Q?;8La@vjges<`wjSbgmL;0XN+WRcR|vx zM`uz;bo#wBa-=p!#&x7Xul5ApZaIgM;=m>B;}GXrr8v(`s`Mh1uANw@GNyc~x9C0` zjoYIKi;V)|sp$~ve`Acgr(@xwwgoMQj`jshw#VnO^YtiPnK*_LVYV_U7ECb~!9Y`n zI=Kbn0+E+`)RS5IXph$-73%`B0%9DGy)kx?*H%vk^t_Zt_>C#;`g-y&z0w6I*6;H> z;LuX(7h~)7D6+5VVqkn*Z;>>#p0H`w84%`)?fRK%RGK0VGr)RcPE&wDtm3mHQ1q!D zQj^ByxQ3Rwv1s44bKCCeZtG}A%Yueg z&w5EXjjxj9pY*UZ%CxU5ilY==!X@juH^AhFonm#hXq~l7sl+qkC~L-$3Ue8(2jJ$g1J^OU`%;{_K~^i9F!=r zNTA5+V=(pWW4_M9-RI>Yuu5B!a|e&!T> z<4E1#) zF5g3!|Hcmfh)p!u^7FyxUJ!0UmWh>sc8O()fd`}IYXCun!45qRabvQu8)`_?h}!_3 zMZ#n;7#=zy+Cz+=+-neWeSRp9faz zHt=#EV@lZICw&GkcUsT|9NshJ#Kfdo)c=kk*?t3;gK%TYA)xxgz{*58xgAVl+AWy* zd4rw}kU@hQ{k7fdx4R0!FImML#b0PvbZZdH8+fufNCA?# z-f?R~{SSk~7+eKNmXXhq?wWC<1H@zGq!v{0jZ|WzG2S=~!!?k*j7-1=SLF(-f%F(@ ze}BmWv-iy z>vE;xq^#NrHbO)7F;rqdbDC}gGlQuDX5)wvsh?m$@{#etosR9=V@6ESgM`aCAWcR} z$-fx^rex4H?pB?F3X*~hC5prauK=cCNPkLrOqBwG-!T6)_>Gc`WC2a^H&IUuvQ`Dj za(Vvt}!t+D1`%Q-tIlLs7`uhk2Ro25^Px-OgCbhrtY^Vl@(DCS$jNcRtGP z;+j5u@K+#A_Gikd8S67~i!Db`5JCnwqPR^p*%9Up# z=$DxaAhD=gq!!6!f=Gb{SQ)=1lMYHeWP%;Q0cIp0BpeGYBCFb?dQ1usAdJWy5->o} zvrXiGG8tO|Y*;nbM83>q+yw!AYtTdnGg-GQ00$<-y5Pkpq9VVs(9<*lr;Al(yH z=3sk-M}lJ0<;PElqtzewNbY4IYu)#V`5I|1g}HFzt*i|R8=w=AhQHsyHC>)_8fCNz z!kPq-Q6+`xI2Kmy>I`ssn}pTUV+Ksi2f*l$$;N2yf>4`nQJ;;hlW47CWaXcsUVtf~ zo}EcN*`fn1ZU`2QsZ@wd5!VSQPaH@wrjJ?5KQ6uqM*|PTY7V10ahN{}IjPKjNaFr^ z1nX09-I68mSR94XBtERbl8#+{C2~7!4d7k^MZjT@?P+kCt0C&W!~8Tj3G`q%{Ozor zSu#K5gXZg}RpV{aEOIRy>ir;IFb~id&cm& zHL|`SLMx%J0i(OgsWF1ABh^ffKb&|v3+?yn?7PYJG5j57iky$fAZ<(zH^N1ca~>eG zNoEco^w~#hEvs&T>)s^H63{HoCgXFW0#Inom${(j02yoeug{bTfVYisaMrDh_g&aMH7#tnvf?9J! ziZAAnf8?l~euv}d436hSWrHsV6JnvT+e_K9I^Z|D01=b|F9WfSe*X*%fD;j; zSOK^c!Ke%s{mopvIvLy|D)pb>TSc9Q?4>U`S%ogwqTVG9>QBT(N|td9>_Z>3Q}{R+ z@tCX4B`b2FXor_pvhl*LC;>7YN(1##c?uRtyKhL}I7v*xWnp4$`U)gb2O$5zW!%Zx z?hI6wcV{5^Y!1MqBPp*wgP{zsE= z2IS6C+w(A8!}>XnRF&73GGAqYzLa`^J<4HU6%+@=R7!nDN~Y0sEakBTf>=zj#Z)}UZJ?^ExKx8znXhBZ!m9l-kX&bW3jZCEF>jjDXJy` z%}Xn>jpd}`Bi6h^+*D@jSi~Y`(O4lD66z_KgP*_$dsI#NH<(}@Axpm3%KKwijz^-qM<)p)g!5#L(p{?RL_|i#H{JrGz zSQbw%&J2-LnNbROt)g&i619oVbOdazx>U-dTVr;a7AY}cjibzk z@|Or&kSye}`vgpx?nozm8cx4Iu7tqXMz71qHk33=$ICKaboru|De*0E_boZ>Fu#O*N0inHg(C)$69H zd1SO1-la8KbQxyU*?A<#%-Fn8vd%DLJ?}r}XoETS|7?yE%)InI^Uf4Auk?>hagLd( zbA+auVTQ}iEPPf?Gs7I$nR&QvfimwjGmP|v8Qz}w9JYpOX1)y`>9PT-R&Et_si;wH z~ zsf?^JQ2W4QqmNbfF$poJnT;B7aFDcNs)R|${M6@jdvm}?q(++?#pHDv2{Z=yS4^?_ zAk1*u$sG0P-Td#_zYf~=zDvdIy>V;Y?#;(9{XMd&pEiK|i=x7}hktvJ-@&|> zwMp|5bC9Q~7os<5Xln1Jfyk~=`I|o241G2q4qNn!wflLj@`q=tq-VHMISWWdKD^kK z7X4}dLh|o?HRS$5zh@T89iyTY%MBQF_oYShn4e1n!ob77z1i!w{3g+I$araMWFg@# zOic*ROmEJ&W24Q<7Cn2(7lE;lL*J6f+P&7^sfUbR!T~2jB+)Zagpb*zi-2la^nS(-zK+CqYg;VkCn&%s*xMN{V37 zT>g^$8)(qTk14=+4Z_THc$&Zt?-*45_=w@wQ!pBcS(?aq78G138C}5Tf-+a%RREEN zw?K8Rhwl{*88;s8qt=)D3UE1f1)U@ylU0!)$wvJl(#sz*_OS49PUwxi=q>1rZ2T1I z7Z-Gqr3ETES^(aGcM9I7q7E4k@V)}+z1d4Z@Ja!T<63lWS!)XH>Kl<61$gy_-y$`m zK!i)XQ($I#$VUZiW{m@~0)grw-xV;KHINmE@U19>#|YM%R-Fi4 z=xItaa7?U=ulj`FU#MpnlWT=cF4|#p;r>Dc{2(l$h=pZ?$rAujlCi%K|3ySz5tED0 zn{cj+Nez&J(L}XEVJ{}WA}$wgD_qhRVge;X0ww3T_mkO0EbIgDyjg&}?k6jX*anvm zuFx=>i-MBO5>{47L~bq;Al-l$FriOOw+mB?wiXo@wH4JCH5NTUUM*sw2x&ZA)XRYc zP-PAlJU|W>F+N-M`J#VpJX|cjb2tH{Um(zUqp0bh65T(GmXP5hsM*6a8iySPqJwkr~{hQOfUSLg6i%8%`m?i@)0D?EapaNFTzs+ zbFrRXN_@qP-5bD?`h-e->QXS`LZ;mhmztn$k>j6CXA6#t=k7}lC)#lWWR1{!x<&U~`SY;yHU01{k;T}=AF+y51$Z=7gtfC#Q82zi14LCnfHWoyg41t6GA175%vj2fSf^#FAA z_|+)J;UQ-s(!C%oQbJ|46>Hb>ZRd~#(MS-i@V0jJw9maE0~gKio@e+G$cor^RCh;* zVd3odC5DbgE$s&E*VQO;h*Gw97-rvdPfHg7ln98M)3T(aeXgMeemYtu+D1`}nCP|z z3tH}-y}&THvu$w;yl6mR>^(hDTW*Icb6Y3Gh8>+t8pT*dsPFIWXunscE#X$ivG%sE z`{GJkjCyt@VMcxd**IhiBXPExi@Zhm2b~SwE;Y9_M4ltH>kc`3I$o%0G?|_xF|$ezA(Y zh9I{$;OHN}?qqM}A>+EgN~ijF<5!dS04HUC7l6FE*K^2-$3!7LiTVuipN|(FgnA16 z5sy&XYaRS*HMt3p0BD)5L08(V88IZ+fi$|5e-LF-RaENl)ycjLXO&U9hKwoY9>hNf zas$fy^D!y`SyReFNB_Li@a>tsQw|x!*MFMBj8cpnS3_(&%tLIe{%Q%twR(0fnN`X< zEgtWNQhF_UvQ%_hvQV<%t=h<@;;Y|Pn*q|}a(YcP(qJ+dB!xK~Rtsl>A{ zr>Cnq`-Bh1zgjBSUK+(`{sk$ro_&bSoFL}HA3s_BHmIh*Kh9hn;xr`#?BB;D@>dgt z5u7pQ#R)QRAKdub$}n#>QwtNYKrp~+AhUTMbeBxV`(V70zmtl+Kkk4=gg0DRqkEX_ zoWMg`4}WU)pVP!6{=s-OR_99Jo3M96c*1GsSg8ssrB6Xr%p5E|1E%0t`1uZe4hdVw z*Jk%KufjJni4c{oVAPQw^`)~P!ZIe#nW$&i-3&FqP1S%#eAy{TD!Z(7 z%cVUZ;)K?H8EQ`NtvY1f^x@_c;V-wy_b?kLUV2eRlje!M+X;zcV7JVB@X$K4b0XvL zLbwu%tRo-7(15n#Gr3bj7PAO~j|$ z_{a66b`pmmX&OIGV%j83q1KaM02ZbIDu@!sDa@UuXE%_glXxgULSc0Kq%EQFkt3Im zoW!4vpFTXa`b>n8{;+4A%=#C*k{^lapk31JI5KA66 zSd4Ctr`{^&+0VdF;yu{&&(ydg}DRCc$v?$ zE8}?C{pi_8NLiV*=MWxZMI9mSW$W?kQ0|ErdG7SD;Ri1cA0eyCpjZON9m(&VfROEF zEIJ4TXh2~fA#axP)_{D!p~wkw_fEJN>*OM(eZYJ(*c>}ZD)iCt3I%-ebXI2dMH!1#bl3}+-8qSSZn^xjRRV|0 z&XpZY|E+{5D;HcIn>&aPwJr$Gay|PfX(;DL0wF~X?tM}z&kh#92sg}l@q;fLo`;rR zil>l%UO6L0QZjV`P-De7c^sA-9womj7e^vSNOu%DC~*wZ(7MXD70ryS*Kp$xc8_Np z#-XB-Bz!q@`S}w|*hSL3`pRkR1ww%a2M9jS)SH9l1yTDTpz(I%apEdd z=H7W!CSUJjCWbf4QrH5A07Vl+yc*_*adM-AtCSaj1InikyDsJN Date: Sun, 11 Apr 2021 22:39:30 +0200 Subject: [PATCH 03/21] Makefile for blkpack/blkunpack --- .gitignore | 2 ++ tools/Makefile | 18 ++++++++++++++++++ 2 files changed, 20 insertions(+) create mode 100644 tools/Makefile diff --git a/.gitignore b/.gitignore index 64a5d91..a73100c 100644 --- a/.gitignore +++ b/.gitignore @@ -2,3 +2,5 @@ *.log /.DS_Store *~ +/tools/blkpack +/tools/blkunpack diff --git a/tools/Makefile b/tools/Makefile new file mode 100644 index 0000000..78583ec --- /dev/null +++ b/tools/Makefile @@ -0,0 +1,18 @@ +BLKPACK_TGT = blkpack +BLKUNPACK_TGT = blkunpack +TARGETS = $(BLKUNPACK_TGT) $(BLKPACK_TGT) + +all: $(TARGETS) + +.SUFFIXES: .c .o +.c.o: + $(CC) $(CFLAGS) -c $< -o $@ + +$(BLKPACK_TGT): $(BLKPACK_TGT).c +$(BLKUNPACK_TGT): $(BLKUNPACK_TGT).c +$(TARGETS): + $(CC) $(CFLAGS) $@.c -o $@ + +.PHONY: clean +clean: + rm -f $(TARGETS) $(OBJS) From e03e2f6abe8347614755a070dfa27bc6303013ad Mon Sep 17 00:00:00 2001 From: Carsten Strotmann Date: Sun, 11 Apr 2021 22:43:24 +0200 Subject: [PATCH 04/21] Initial bare metal 8086 port --- 8086/pc-baremetal/Makefile | 16 + 8086/pc-baremetal/kernel.fth | 2145 ++++++++++++++++++++++++++++++++++ 8086/pc-baremetal/meta.fth | 545 +++++++++ 3 files changed, 2706 insertions(+) create mode 100644 8086/pc-baremetal/Makefile create mode 100644 8086/pc-baremetal/kernel.fth create mode 100644 8086/pc-baremetal/meta.fth diff --git a/8086/pc-baremetal/Makefile b/8086/pc-baremetal/Makefile new file mode 100644 index 0000000..f2931ce --- /dev/null +++ b/8086/pc-baremetal/Makefile @@ -0,0 +1,16 @@ +TARGET = forth.com +BASE = ../.. +BLKPACK = $(BASE)/tools/blkpack + +.PHONY: all +all: $(TARGET) + +%.fb: %.fth $(BLKPACK) + $(BLKPACK) < $< > $@ + +$(TARGET): kernel.fb meta.fb + emu2 $(BASE)/8086/msdos/volks4th.com "include kernel.fb" + +.PHONY: clean +clean: + rm -f $(TARGET) meta.com *.fb diff --git a/8086/pc-baremetal/kernel.fth b/8086/pc-baremetal/kernel.fth new file mode 100644 index 0000000..f268664 --- /dev/null +++ b/8086/pc-baremetal/kernel.fth @@ -0,0 +1,2145 @@ +( ----- 000 ) +\ #### volksFORTH #### cas 18jul20 +VolksForth has been developed by + + K. Schleisiek, B. Pennemann, G. Rehfeld, D. Weineck + Ulli Hoffmann, Philip Zembrod, Carsten Strotmann +6502 version by B.Pennemann and K.Schleisiek +Port to C64 "ultraFORTH" by G. Rehfeld +Port to 68000 and Atari ST by D.Weineck and B.Pennemann +Port to 8080 and CP/M by U.Hoffmann jul 86 +Port to C16 "ultraFORTH" by C.Vogt +Port to 8088/86 and MS-DOS by K.Schleisiek dez 87 +( ----- 001 ) +\ MS-DOS volksForth Load Screen ks cas 18jul20 + Onlyforth \needs Transient include meta.fb + + 2 loadfrom META.fb + + new FORTH.COM Onlyforth Target definitions + + 4 &111 thru \ Standard 8088-System + + flush \ close FORTH.COM + +cr .( new kernel as "FORTH.COM" written) cr bell bye +( ----- 002 ) +\\ Die Nutzung der 8088/86 Register ks 27 oct 86 + +Im Assembler sind Forthgemaesse Namen fuer die Register gewaehlt +Dabei ist die Zuordnung zu den Intel Namen folgendermassen: + +A <=> AX A- <=> AL A+ <=> AH +C <=> CX C- <=> CL C+ <=> CH + Register A und C sind zur allgemeinen Benutzung frei + +D <=> DX D- <=> DL D+ <=> DH + das oberste Element des (Daten)-Stacks. + +R <=> BX R- <=> RL R+ <=> RH + der Return_stack_pointer +( ----- 003 ) +\\ Die Nutzung der 8088/86 Register ks 27 oct 86 + +U <=> BP User_area_pointer +S <=> SP Daten_stack_pointer +I <=> SI Instruction_pointer +W <=> DI Word_pointer, im allgemeinen zur Benutzung frei. + +D: <=> DS E: <=> ES S: <=> SS C: <=> CS + Alle Segmentregister werden beim booten auf den Wert des + Codesegments C: gesetzt und muessen, wenn sie "verstellt" + werden, wieder auf C: zurueckgesetzt werden. +( ----- 004 ) +\ FORTH Preamble and ID ks 11 m„r 89 +Assembler + +nop 5555 # jmp here 2- >label >cold +nop 5555 # jmp here 2- >label >restart + +Create origin here origin! here $100 0 fill +\ Hier beginnen die Kaltstartwerte der Benutzervariablen + + $E9 int end-code -4 , $FC allot +\ this is the multitasker initialization in the user area + +| Create logo ," volksFORTH-83 rev. 3.81.41" +( ----- 005 ) +\ Next ks 27 oct 86 + + Variable next-link 0 next-link ! + + Host Forth Assembler also definitions + + : Next lods A W xchg W ) jmp + there tnext-link @ T , H tnext-link ! ; + +\ Next ist in-line code. Fuer den debugger werden daher alle +\ "nexts" in einer Liste mit dem Anker NEXT-LINK verbunden. + + : u' ( -- offset ) T ' 2+ c@ H ; + + Target +( ----- 006 ) +\ recover ;c: noop ks 27 oct 86 + + Create recover Assembler + R dec R dec I R ) mov I pop Next + end-code + +Host Forth Assembler also definitions + + : ;c: 0 T recover # call ] end-code H ; + +Target + +| Code di cli Next end-code +| Code ei sti here Next end-code + + Code noop here 2- ! end-code +( ----- 007 ) +\ User variables ks 16 sep 88 + 8 uallot drop \ Platz fuer Multitasker + \ Felder: entry link spare SPsave + \ Laenge kompatibel zum 68000, 6502 und 8080 volksFORTH + User s0 + User r0 + User dp + User offset 0 offset ! + User base &10 base ! + User output + User input + User errorhandler \ pointer for Abort" -code + User aborted \ code address of latest error + User voc-link + User file-link cr .( Wieso ist UDP Uservariable? ) + User udp \ points to next free addr in User_area +( ----- 008 ) +\ manipulate system pointers ks 03 aug 87 + + Code sp@ ( -- addr ) D push S D mov Next end-code + + Code sp! ( addr -- ) D S mov D pop Next end-code + + + Code up@ ( -- addr ) D push U D mov Next end-code + + Code up! ( addr -- ) D U mov D pop Next end-code + + Code ds@ ( -- addr ) D push D: D mov Next end-code + + $10 Constant b/seg \ bytes per segment +( ----- 009 ) +\ manipulate returnstack ks 27 oct 86 + + Code rp@ ( -- addr ) D push R D mov Next end-code + + Code rp! ( addr -- ) D R mov D pop Next end-code + + + Code >r ( 16b -- ) R dec R dec D R ) mov D pop Next + end-code restrict + + Code r> ( -- 16b ) D push R ) D mov R inc R inc Next + end-code restrict +( ----- 010 ) +\ r@ rdrop exit unnest ?exit ks 27 oct 86 + Code r@ ( -- 16b ) D push R ) D mov Next end-code + + Code rdrop R inc R inc Next end-code restrict + + Code exit + Label >exit R ) I mov R inc R inc Next end-code + + Code unnest >exit here 2- ! end-code + + Code ?exit ( flag -- ) + D D or D pop >exit 0= ?] [[ Next end-code + + Code 0=exit ( flag -- ) + D D or D pop >exit 0= not ?] ]] end-code +\ : ?exit ( flag -- ) IF rdrop THEN ; +( ----- 011 ) +\ execute perform ks 27 oct 86 + + Code execute ( acf -- ) D W mov D pop W ) jmp end-code + + Code perform ( addr -- ) D W mov D pop W ) W mov W ) jmp + end-code + +\ : perform ( addr -- ) @ execute ; +( ----- 012 ) +\ c@ c! ctoggle ks 27 oct 86 + + Code c@ ( addr -- 8b ) + D W mov W ) D- mov 0 # D+ mov Next end-code + + Code c! ( 16b addr -- ) + D W mov A pop A- W ) mov D pop Next end-code + + Code ctoggle ( 8b addr -- ) + D W mov A pop A- W ) xor D pop Next end-code + +\ : ctoggle ( 8b addr -- ) under c@ xor swap c! ; + + Code flip ( 16b1 -- 16b2 ) D- D+ xchg Next end-code +( ----- 013 ) +\ @ ! 2@ 2! ks 27 oct 86 + + Code @ ( addr -- 16b ) D W mov W ) D mov Next end-code + + Code ! ( 16b addr -- ) D W mov W ) pop D pop Next + end-code + + : 2@ ( addr -- 32b ) dup 2+ @ swap @ ; + + : 2! ( 32b addr -- ) under ! 2+ ! ; +( ----- 014 ) +\ +! drop swap ks 27 oct 86 + + Code +! ( 16b addr -- ) + D W mov A pop A W ) add D pop Next end-code + +\ : +! ( n addr -- ) under @ + swap ! ; + + + Code drop ( 16b -- ) D pop Next end-code + + Code swap ( 16b1 16b2 -- 16b2 16b1 ) + A pop D push A D xchg Next end-code +( ----- 015 ) +\ dup ?dup ks 27 oct 86 + + Code dup ( 16b -- 16b 16b ) D push Next end-code + +\ : dup ( 16b -- 16b 16b ) sp@ @ ; + + Code ?dup ( 16b -- 16b 16b / false ) + D D or 0= not ?[ D push ]? Next end-code + +\ : ?dup ( 16b -- 16b 16b / false) dup 0=exit dup ; +( ----- 016 ) +\ over rot nip under ks 27 oct 86 + + Code over ( 16b1 16b2 -- 16b1 16b2 16b1 ) + A D xchg D pop D push A push Next end-code +\ : over >r dup r> swap ; + + Code rot ( 16b1 16b2 16b3 -- 16b2 16b3 16b1 ) + A D xchg C pop D pop C push A push Next end-code +\ : rot >r swap r> swap ; + + Code nip ( 16b1 16b2 -- 16b2 ) S inc S inc Next end-code +\ : nip swap drop ; + + Code under ( 16b1 16b2 -- 16b2 16b1 16b2 ) + A pop D push A push Next end-code +\ : under swap over ; +( ----- 017 ) +\ -rot pick ks 27 oct 86 + + Code -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) + A D xchg D pop C pop A push C push Next end-code + +\ : -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) rot rot ; + + Code pick ( n -- 16b.n ) + D sal D W mov S W add W ) D mov Next end-code + +\ : pick ( n -- 16b.n ) 1+ 2* sp@ + @ ; +( ----- 018 ) +\ roll -roll ks 27 oct 86 + + Code roll ( n -- ) + A I xchg D sal D C mov D I mov S I add + I ) D mov I W mov I dec W inc std + rep byte movs cld A I xchg S inc S inc Next + end-code +\ : roll ( n -- ) +\ dup >r pick sp@ dup 2+ r> 1+ 2* cmove> drop ; + + Code -roll ( n -- ) A I xchg D sal D C mov + S W mov D pop S I mov S dec S dec + rep byte movs D W ) mov D pop A I xchg Next + end-code +\ : -roll ( n -- ) >r dup sp@ dup 2+ +\ dup 2+ swap r@ 2* cmove r> 1+ 2* + ! ; +( ----- 019 ) +\ 2swap 2drop 2dup 2over ks 27 oct 86 + Code 2swap ( 32b1 32b2 -- 32b2 32b1 ) C pop A pop W pop + C push D push W push A D xchg Next end-code +\ : 2swap ( 32b1 32b2 -- 32b2 32b1 ) rot >r rot r> ; + + Code 2drop ( 32b -- ) S inc S inc D pop Next end-code +\ : 2drop ( 32b -- ) drop drop ; + + Code 2dup ( 32b -- 32b 32b ) + S W mov D push W ) push Next end-code +\ : 2dup ( 32b -- 32b 32b ) over over ; + + Code 2over ( 1 2 x x -- 1 2 x x 1 2 ) + D push S W mov 6 W D) push 4 W D) D mov Next + end-code +\ : 2over ( 1 2 x x -- 1 2 x x 1 2 ) 3 pick 3 pick ; +( ----- 020 ) +\ and or xor not ks 27 oct 86 + + Code not ( 16b1 -- 16b2 ) D com Next end-code + + Code and ( 16b1 16b2 -- 16b3 ) + A pop A D and Next end-code + + Code or ( 16b1 16b2 -- 16b3 ) + A pop A D or Next end-code +\ : or ( 16b1 16b2 -- 16b3 ) not swap not and not ; + + Code xor ( 16b1 16b2 -- 16b3 ) + A pop A D xor Next end-code +( ----- 021 ) +\ + - negate ks 27 oct 86 + + Code + ( n1 n2 -- n3 ) A pop A D add Next end-code + + Code negate ( n1 -- n2 ) D neg Next end-code +\ : negate ( n1 -- n2 ) not 1+ ; + + Code - ( n1 n2 -- n3 ) + A pop D A sub A D xchg Next end-code +\ : - ( n1 n2 -- n3 ) negate + ; +( ----- 022 ) +\ dnegate d+ ks 27 oct 86 + + Code dnegate ( d1 -- -d1 ) D com A pop A neg + CS not ?[ D inc ]? A push Next end-code + + Code d+ ( d1 d2 -- d3 ) A pop C pop W pop + W A add A push C D adc Next end-code +( ----- 023 ) +\ 1+ 2+ 3+ 4+ 6+ 1- 2- 4- ks 27 oct 86 + + Code 1+ ( n1 -- n2 ) [[ D inc Next + Code 2+ ( n1 -- n2 ) [[ D inc swap ]] + Code 3+ ( n1 -- n2 ) [[ D inc swap ]] + Code 4+ ( n1 -- n2 ) [[ D inc swap ]] +| Code 6+ ( n1 -- n2 ) D inc D inc ]] end-code + + Code 1- ( n1 -- n2 ) [[ D dec Next + Code 2- ( n1 -- n2 ) [[ D dec swap ]] + Code 4- ( n1 -- n2 ) D dec D dec ]] end-code +( ----- 024 ) +\ number Constants ks 30 jan 88 +-1 Constant true 0 Constant false + + 0 ( -- 0 ) Constant 0 + 1 ( -- 1 ) Constant 1 + 2 ( -- 2 ) Constant 2 + 3 ( -- 3 ) Constant 3 + 4 ( -- 4 ) Constant 4 + -1 ( -- -1 ) Constant -1 + + Code on ( addr -- ) -1 # A mov +[[ D W mov A W ) mov D pop Next + Code off ( addr -- ) 0 # A mov ]] end-code + +\ : on ( addr -- ) true swap ! ; +\ : off ( addr -- ) false swap ! ; +( ----- 025 ) +\ words for number literals ks 27 oct 86 + + Code lit ( -- 16b ) D push I ) D mov I inc +[[ I inc Next end-code restrict + + Code clit ( -- 8b ) + D push I ) D- mov 0 # D+ mov ]] end-code restrict + + : Literal ( 16b -- ) + dup $FF00 and IF compile lit , exit THEN + compile clit c, ; immediate restrict +( ----- 026 ) +\ comparision code words ks 27 oct 86 + + Code 0= ( 16b -- flag ) + D D or 0 # D mov 0= ?[ D dec ]? Next end-code + + Code 0<> ( n -- flag ) + D D or 0 # D mov 0= not ?[ D dec ]? Next end-code +\ : 0<> ( n -- flag ) 0= not ; + + Code u< ( u1 u2 -- flag ) A pop +[[ D A sub 0 # D mov CS ?[ D dec ]? Next end-code + + Code u> ( u1 u2 -- flag ) A D xchg D pop ]] end-code +\ : u> ( u1 u2 -- flag ) swap u< ; +( ----- 027 ) +\ comparision words ks 13 sep 88 + Code < ( n1 n2 -- flag ) A pop +[[ [[ D A sub 0 # D mov < ?[ D dec ]? Next end-code + + Code > ( n1 n2 -- flag ) A D xchg D pop ]] end-code + + Code 0> ( n -- flag ) A A xor ]] end-code + +\ : < ( n1 n2 -- flag ) +\ 2dup xor 0< IF drop 0< exit THEN - 0< ; +\ : > ( n1 n2 -- flag ) swap < ; +\ : 0> ( n -- flag ) negate 0< ; + + Code 0< ( n1 n2 -- flag ) + D D or 0 # D mov 0< ?[ D dec ]? Next end-code +\ : 0< ( n1 -- flag ) 8000 and 0<> ; +( ----- 028 ) +\ comparision words ks 27 oct 86 + + Code = ( n1 n2 -- flag ) A pop A D cmp + 0 # D mov 0= ?[ D dec ]? Next end-code +\ : = ( n1 n2 -- flag ) - 0= ; + + Code uwithin ( u1 [low high[ -- flag ) A pop C pop + A C cmp CS ?[ [[ swap 0 # D mov Next ]? + D C cmp CS ?] -1 # D mov Next end-code +\ : uwithin ( u1 [low up[ -- f ) over - -rot - u> ; + + Code case? ( 16b1 16b2 -- 16b1 ff / tf ) A pop A D sub + 0= ?[ D dec ][ A push D D xor ]? Next end-code +\ : case? ( 16b1 16b2 -- 16b1 false / true ) +\ over = dup 0=exit nip ; +( ----- 029 ) +\ double number comparisons ks 27 oct 86 + + Code d0= ( d - f) A pop A D or + 0= not ?[ 1 # D mov ]? D dec Next end-code +\ : d0= ( d -- flag ) or 0= ; + + : d= ( d1 d2 -- flag ) dnegate d+ d0= ; + +Code d< ( d1 d2 -- flag ) C pop A pop + D A sub A pop -1 # D mov < ?[ [[ swap Next ]? + 0= ?[ C A sub CS ?[ D dec ]? ]? D inc ]] end-code +\ : d< ( d1 d2 -- flag ) +\ rot 2dup - IF > nip nip exit THEN 2drop u< ; +( ----- 030 ) +\ min max umax umin abs dabs extend ks 27 oct 86 + Code min ( n1 n2 -- n3 ) A pop A D sub < ?[ D A add ]? + [[ [[ [[ A D xchg Next end-code + Code max ( n1 n2 -- n3 ) + A pop A D sub dup < not ?] D A add ]] end-code + Code umin ( u1 u2 -- u3 ) + A pop A D sub dup CS ?] D A add ]] end-code + Code umax ( u1 u2 -- u3 ) + A pop A D sub dup CS not ?] D A add ]] end-code + + Code extend ( n -- d ) + A D xchg cwd A push Next end-code + + Code abs ( n -- u ) D D or 0< ?[ D neg ]? Next end-code + + : dabs ( d -- ud ) extend 0=exit dnegate ; +( ----- 031 ) +\\ min max umax umin extend 10Mar8 + +| : minimax ( n1 n2 flag -- n3 ) rdrop IF swap THEN drop ; + +: min ( n1 n2 -- n3 ) 2dup > minimax ; +: max ( n1 n2 -- n3 ) 2dup < minimax ; +: umax ( u1 u2 -- u3 ) 2dup u< minimax ; +: umin ( u1 u2 -- u3 ) 2dup u> minimax ; +: extend ( n -- d ) dup 0< ; +: dabs ( d -- ud ) extend IF dnegate THEN ; +: abs ( n -- u) extend IF negate THEN ; +( ----- 032 ) +\ (do (?do endloop bounds ks 30 jan 88 + + Code (do ( limit start -- ) A pop +[[ $80 # A+ xor R dec R dec I inc I inc + I R ) mov R dec R dec A R ) mov R dec R dec + A D sub D R ) mov D pop Next end-code restrict + + Code (?do ( limit start -- ) A pop A D cmp 0= ?] + I ) I add D pop Next end-code restrict + + Code endloop 6 # R add Next end-code restrict + + Code bounds ( start count -- limit start ) + A pop A D xchg D A add A push Next end-code +\ : bounds ( start count -- limit start ) over + swap ; +( ----- 033 ) +\ (loop (+loop ks 27 oct 86 + + Code (loop R ) word inc +[[ OS not ?[ 4 R D) I mov ]? Next end-code restrict + + Code (+loop D R ) add D pop ]] end-code restrict + +\\ + +| : dodo rdrop r> 2+ dup >r rot >r swap >r >r ; +\ dodo puts "index | limit | adr.of.DO" on return-stack + + : (do ( limit start -- ) over - dodo ; restrict + : (?do ( limit start -- ) over - ?dup IF dodo THEN + r> dup @ + >r drop ; restrict +( ----- 034 ) +\ loop indices ks 27 oct 86 + + Code I ( -- n ) D push R ) D mov 2 R D) D add Next + end-code +\ : I ( -- n ) r> r> dup r@ + -rot >r >r ; + + Code J ( -- n ) D push 6 R D) D mov 8 R D) D add Next + end-code +( ----- 035 ) +\ branch ?branch ks 27 oct 86 + + Code branch +[[ I ) I add Next end-code restrict +\ : branch r> dup @ + >r ; + + Code ?branch D D or D pop 0= not ?] + I inc I inc Next end-code restrict +( ----- 036 ) +\ resolve loops and branches ks 02 okt 87 + + : >mark ( -- addr ) here 0 , ; + + : >resolve ( addr -- ) here over - swap ! ; + + : mark 1 ; immediate restrict + : THEN abs 1 ?pairs >resolve ; immediate restrict + : ELSE 1 ?pairs compile branch >mark + swap >resolve -1 ; immediate restrict + + : BEGIN mark -2 2swap ; immediate restrict + +| : (repeat 2 ?pairs resolve REPEAT ; + + : REPEAT compile branch (repeat ; immediate restrict + : UNTIL compile ?branch (repeat ; immediate restrict +( ----- 038 ) +\ Loops ks 27 oct 86 + + : DO compile (do >mark 3 ; immediate restrict + : ?DO compile (?do >mark 3 ; immediate restrict + : LOOP 3 ?pairs compile (loop + compile endloop >resolve ; immediate restrict + : +LOOP 3 ?pairs compile (+loop + compile endloop >resolve ; immediate restrict + + Code LEAVE 6 # R add -2 R D) I mov + I dec I dec I ) I add Next end-code restrict + +\ : LEAVE endloop r> 2- dup @ + >r ; restrict +\ Returnstack: | calladr | index | limit | adr of DO | +( ----- 039 ) +\ um* m* * ks 29 jul 87 + + Code um* ( u1 u2 -- ud3 ) + A D xchg C pop C mul A push Next end-code + + Code m* ( n1 n2 -- d3 ) + A D xchg C pop C imul A push Next end-code +\ : m* ( n1 n2 -- d ) dup 0< dup >r IF negate THEN swap +\ dup 0< IF negate r> not >r THEN um* r> 0=exit dnegate ; + + : * ( n1 n2 - prod ) um* drop ; + + Code 2* ( u -- 2*u ) D shl Next end-code +\ : 2* ( u -- 2*u ) dup + ; +( ----- 040 ) +\ um/mod m/mod ks 27 oct 86 + + Code um/mod ( ud1 u2 -- urem uquot ) + D C mov D pop A pop C div A D xchg A push Next + end-code + + Code m/mod ( d1 n2 -- rem quot ) D C mov D pop +Label divide D+ A+ mov C+ A+ xor A pop 0< not + ?[ C idiv [[ swap A D xchg A push Next ]? + C idiv D D or dup 0= not ?] A dec C D add ]] + end-code + +\ : m/mod ( d n -- mod quot ) dup >r +\ abs over 0< IF under + swap THEN um/mod r@ 0< +\ IF negate over IF swap r@ + swap 1- THEN THEN rdrop ; +( ----- 041 ) +\ /mod division trap 2/ ks 13 sep 88 + + Code /mod ( n1 n2 -- rem quot ) + D C mov A pop cwd A push divide ]] end-code +\ : /mod ( n1 n2 -- rem quot ) over 0< swap m/mod ; + + 0 >label >divINT + + Label divovl Assembler + 4 # S add popf 1 # D- mov ;c: Abort" / overflow" ; + + Code 2/ ( n1 -- n/2 ) D sar Next end-code +\ : 2/ ( n -- n/2 ) 2 / ; +( ----- 042 ) +\ / mod */mod */ u/mod ud/mod ks 27 oct 86 + + : / ( n1 n2 -- quot ) /mod nip ; + + : mod ( n1 n2 -- rem ) /mod drop ; + + : */mod ( n1 n2 n3 -- rem quot ) >r m* r> m/mod ; + + : */ ( n1 n2 n3 -- quot ) */mod nip ; + + : u/mod ( u1 u2 -- urem uquot ) 0 swap um/mod ; + + : ud/mod ( ud1 u2 -- urem udquot ) + >r 0 r@ um/mod r> swap >r um/mod r> ; +( ----- 043 ) +\ cmove cmove> move ks 27 oct 86 + + Code cmove ( from to quan -- ) A I xchg D C mov + W pop I pop D pop rep byte movs A I xchg Next + end-code + + Code cmove> ( from to quan -- ) + A I xchg D C mov W pop I pop D pop +Label moveup C dec C W add C I add C inc + std rep byte movs A I xchg cld Next end-code + + Code move ( from to quan -- ) + A I xchg D C mov W pop I pop D pop +Label domove I W cmp moveup CS ?] + rep byte movs A I xchg Next end-code +( ----- 044 ) +\ place count ks 27 oct 86 + +| Code (place ( addr len to - len to) A I xchg D W mov + C pop I pop C push W inc domove ]] end-code + + : place ( addr len to -) (place c! ; + + Code count ( addr -- addr+1 len ) D W mov + W ) D- mov 0 # D+ mov W inc W push Next end-code + +\ : move ( from to quan -- ) +\ >r 2dup u< IF r> cmove> exit THEN r> cmove ; +\ : place ( addr len to -- ) over >r rot over 1+ r> move c! ; +\ : count ( adr -- adr+1 len ) dup 1+ swap c@ ; +( ----- 045 ) +\ fill erase ks 27 oct 86 + + Code fill ( addr quan 8b -- ) + D A xchg C pop W pop D pop rep byte stos Next + end-code + +\ : fill ( addr quan 8b -- ) swap ?dup +\ IF >r over c! dup 1+ r> 1- cmove exit THEN 2drop ; + + : erase ( addr quan --) 0 fill ; +( ----- 046 ) +\ here allot , c, pad compile ks 27 oct 86 + + Code here ( -- addr ) D push u' dp U D) D mov Next + end-code +\ : here ( -- addr ) dp @ ; + + Code allot ( n -- ) D u' dp U D) add D pop Next + end-code +\ : allot ( n -- ) dp +! ; + + : , ( 16b -- ) here ! 2 allot ; + : c, ( 8b -- ) here c! 1 allot ; + : pad ( -- addr ) here $42 + ; + : compile r> dup 2+ >r @ , ; restrict +( ----- 047 ) +\ input strings ks 23 dez 87 + + Variable #tib #tib off + Variable >tib here >tib ! $50 allot + Variable >in >in off + Variable blk blk off + Variable span span off + + : tib ( -- addr ) >tib @ ; + + : query tib $50 expect span @ #tib ! >in off ; +( ----- 048 ) +\ skip scan /string ks 22 dez 87 + + Code skip ( addr len char -- addr1 len1 ) + A D xchg C pop C0= not + ?[ W pop 0=rep byte scas 0= not ?[ W dec C inc ]? + W push ]? C D mov Next end-code + + Code scan ( addr0 len0 char -- addr1 len1 ) + A D xchg C pop C0= not + ?[ W pop 0<>rep byte scas 0= ?[ W dec C inc ]? + W push ]? C D mov Next end-code + + Code /string ( addr0 len0 +n -- addr1 len1 ) + A pop C pop D A sub CS ?[ A D add A A xor ]? + C D add D push A D xchg Next end-code +( ----- 049 ) +\\ scan skip /string ks 29 jul 87 + + : skip ( addr0 len0 char -- addr1 len1 ) >r + BEGIN dup + WHILE over c@ r@ = WHILE 1- swap 1+ swap + REPEAT rdrop ; + + : scan ( addr0 len0 char -- addr1 len1 ) >r + BEGIN dup + WHILE over c@ r@ - WHILE 1- swap 1+ swap + REPEAT rdrop ; + + : /string ( addr0 len0 +n -- addr1 len1 ) + over umin rot over + -rot - ; +( ----- 050 ) +\ capital ks 19 dez 87 + + Create (capital Assembler $61 # A- cmp CS not + ?[ $7B # A- cmp CS not + ?[ $84 # A- cmp 0= ?[ $8E # A- mov ret ]? \ + $94 # A- cmp 0= ?[ $99 # A- mov ret ]? \ + $81 # A- cmp 0= ?[ $9A # A- mov ]? ret \ + ]? $20 # A- xor + ]? ret end-code + + Code capital ( char -- char' ) + A D xchg (capital # call A D xchg Next + end-code +( ----- 051 ) +\ upper ks 03 aug 87 + + Code upper ( addr len -- ) + D C mov W pop D pop C0= not + ?[ [[ W ) A- mov (capital # call + A- W ) mov W inc C0= ?] ]? Next + end-code + +\\ high level, ohne Umlaute + + : capital ( char -- char') + dup Ascii a [ Ascii z 1+ ] Literal + uwithin not ?exit [ Ascii a Ascii A - ] Literal - ; + + : upper ( addr len -- ) + bounds ?DO I c@ capital I c! LOOP ; +( ----- 052 ) +\ (word ks 28 mai 87 + +| Code (word ( char addr0 len0 -- addr1 ) D C mov W pop + A pop >in #) D mov D C sub >= not + ?[ C push D W add 0=rep byte scas W D mov 0= not + ?[ W dec D dec C inc + 0<>rep byte scas 0= ?[ W dec ]? + ]? A pop C A sub A >in #) add + W C mov D C sub 0= not + ?[ D I xchg u' dp U D) W mov C- W ) mov + W inc rep byte movs $20 # W ) byte mov + D I mov u' dp U D) D mov Next +swap ]? C >in #) add + ]? u' dp U D) W mov $2000 # W ) mov W D mov Next + end-code +( ----- 053 ) +\\ (word ks 27 oct 86 + +| : (word ( char adr0 len0 -- addr ) + rot >r over swap >in @ /string r@ skip + over swap r> scan >r rot over swap - r> 0<> - >in ! + over - here dup >r place bl r@ count + c! r> ; +( ----- 054 ) +\ source word parse name ks 03 aug 87 + + Variable loadfile loadfile off + + : source ( -- addr len ) blk @ ?dup + IF loadfile @ (block b/blk exit THEN tib #tib @ exit ; + + : word ( char -- addr ) source (word ; + + : parse ( char -- addr len ) >r source >in @ /string + over swap r> scan >r over - dup r> 0<> - >in +! ; + + : name ( -- string ) bl word dup count upper exit ; +( ----- 055 ) +\ state Ascii ," "lit (" " ks 16 sep 88 + Variable state state off + + : Ascii ( char -- n ) bl word 1+ c@ + state @ 0=exit [compile] Literal ; immediate + + : ," Ascii " parse here over 1+ allot place ; + + Code "lit ( -- addr ) D push R ) D mov D W mov + W ) A- mov 0 # A+ mov A inc A R ) add Next + end-code restrict +\ : "lit r> r> under count + even >r >r ; restrict + + : (" "lit ; restrict + + : " compile (" ," align ; immediate restrict +( ----- 056 ) +\ ." ( .( \ \\ hex decimal ks 12 dez 88 + + : (." "lit count type ; restrict + : ." compile (." ," align ; immediate restrict + + : ( Ascii ) parse 2drop ; immediate + : .( Ascii ) parse type ; immediate + + : \ >in @ negate c/l mod >in +! ; immediate + : \\ b/blk >in ! ; immediate + : have ( -- f ) name find nip 0<> ; immediate + : \needs have 0=exit [compile] \ ; + + : hex $10 base ! ; + : decimal &10 base ! ; +( ----- 057 ) +\ number conversion: digit? accumulate convert ks 08 okt 87 + + : digit? ( char -- digit true/ false ) dup Ascii 9 > + IF [ Ascii A Ascii 9 - 1- ] Literal - dup Ascii 9 > and + THEN Ascii 0 - dup base @ u< dup ?exit nip ; + + : accumulate ( +d0 adr digit -- +d1 adr ) swap >r + swap base @ um* drop rot base @ um* d+ r> ; + + : convert ( +d1 addr0 -- +d2 addr2 ) + 1+ BEGIN count digit? WHILE accumulate REPEAT 1- ; +( ----- 058 ) +\ number conversion ks 29 jun 87 +| : end? ( -- flag ) >in @ 0= ; + +| : char ( addr0 -- addr1 char ) count -1 >in +! ; + +| : previous ( addr0 -- addr0 char ) 1- count ; + +| : punctuation? ( char -- flag ) + Ascii , over = swap Ascii . = or ; +\ : punctuation? ( char -- f ) ?" .," ; + +| : fixbase? ( char -- char false / newbase true ) capital + Ascii $ case? IF $10 true exit THEN + Ascii H case? IF $10 true exit THEN + Ascii & case? IF &10 true exit THEN + Ascii % case? IF 2 true exit THEN false ; +( ----- 059 ) +\ number conversion: dpl ?num ?nonum ?dpl ks 27 oct 86 + + Variable dpl -1 dpl ! + +| : ?num ( flag -- exit if true ) 0=exit + rdrop drop r> IF dnegate THEN rot drop + dpl @ 1+ ?dup ?exit drop true ; + +| : ?nonum ( flag -- exit if true ) 0=exit + rdrop 2drop drop rdrop false ; + +| : ?dpl dpl @ -1 = ?exit 1 dpl +! ; +( ----- 060 ) +\ number conversion: number? number ks 27 oct 86 + + : number? ( string -- string false / n 0< / d 0> ) + base push >in push dup count >in ! dpl on + 0 >r ( +sign) 0.0 rot end? ?nonum char + Ascii - case? IF rdrop true >r end? ?nonum char THEN + fixbase? IF base ! end? ?nonum char THEN + BEGIN digit? 0= ?nonum + BEGIN accumulate ?dpl end? ?num char digit? + 0= UNTIL previous punctuation? 0= ?nonum + dpl off end? ?num char + REPEAT ; + + : number ( string -- d ) + number? ?dup 0= Abort" ?" 0> ?exit extend ; +( ----- 061 ) +\ hide reveal immediate restrict ks 18 m„r 88 + Variable last last off + + : last' ( -- cfa ) last @ name> ; + +| : last? ( -- false / nfa true) last @ ?dup ; + : hide last? 0=exit 2- @ current @ ! ; + : reveal last? 0=exit 2- current @ ! ; + + : Recursive reveal ; immediate restrict + +| : flag! ( 8b --) + last? IF under c@ or over c! THEN drop ; + + : immediate $40 flag! ; + : restrict $80 flag! ; +( ----- 062 ) +\ clearstack hallot heap heap? ks 27 oct 86 + + Code clearstack u' s0 U D) S mov D pop Next end-code + + : hallot ( quan -- ) + s0 @ over - swap sp@ 2+ dup rot - dup s0 ! + 2 pick over - di move clearstack ei s0 ! ; + + : heap ( -- addr ) s0 @ 6 + ; + : heap? ( addr -- flag ) heap up@ uwithin ; + +| : heapmove ( from -- from ) + dup here over - dup hallot + heap swap cmove heap over - last +! reveal ; +( ----- 063 ) +\ Does> ; ks 18 m„r 88 + +| Create dodo Assembler + R dec R dec I R ) mov \ push IP + D push 2 W D) D lea \ load parameter address + W ) I mov 3 # I add Next end-code + + dodo Host tdodo ! Target \ target compiler needs to know + + : (;code r> last' ! ; + + : Does> compile (;code $E9 c, ( jmp instruction) + dodo here 2+ - , ; immediate restrict +( ----- 064 ) +\ ?head | alignments ks 19 m„r 88 + Variable ?head ?head off + + : | ?head @ ?exit ?head on ; + + : even ( addr -- addr1 ) ; immediate + : align ( -- ) ; immediate + : halign ( -- ) ; immediate +\ machen nichts beim 8088. 8086 koennte etwas schneller werden + + Variable warning warning on + +| : ?exists warning @ 0=exit + last @ current @ (find nip 0=exit + space last @ .name ." exists " ?cr ; +( ----- 065 ) +\ Create Variable ks 19 m„r 88 + + Defer makeview ' 0 Is makeview + + : Create align here makeview , current @ @ , + name c@ dup 1 $20 uwithin not Abort" invalid name" + here last ! 1+ allot align ?exists + ?head @ IF 1 ?head +! dup , \ Pointer to Code + halign heapmove $20 flag! dup dp ! + THEN drop reveal 0 , + ;Code ( -- addr ) D push 2 W D) D lea Next end-code + + : Variable Create 0 , ; +( ----- 066 ) +\ nfa? ks 28 mai 87 + + Code nfa? ( thread cfa -- nfa / false ) + W pop R A mov $1F # C mov + [[ W ) W mov W W or 0= not + ?[[ 2 W D) R- mov C R and 3 R W DI) R lea + $20 # 2 W D) test 0= not ?[ R ) R mov ]? + D R cmp 0= ?] 2 W D) W lea + ]? W D mov A R mov Next end-code + +\\ + + : nfa? ( thread cfa -- nfa / false ) >r + BEGIN @ dup 0= IF rdrop exit THEN + dup 2+ name> r@ = UNTIL 2+ rdrop ; +( ----- 067 ) +\ >name name> >body .name ks 13 aug 87 + + : >name ( acf -- anf / ff ) voc-link + BEGIN @ dup WHILE 2dup 4 - swap nfa? + ?dup IF -rot 2drop exit THEN REPEAT nip ; + + : (name> ( nfa -- cfa ) count $1F and + even ; + + : name> ( nfa -- cfa ) + dup (name> swap c@ $20 and 0=exit @ ; + + : >body ( cfa -- pfa ) 2+ ; + : body> ( pfa -- cfa ) 2- ; + + : .name ( nfa -- ) ?dup IF dup heap? IF ." | " THEN + count $1F and type ELSE ." ???" THEN space ; +( ----- 068 ) +\ : ; Constant Variable ks 29 oct 86 + + : Create: Create hide current @ context ! 0 ] ; + + : : Create: + ;Code R dec R dec I R ) mov 2 W D) I lea Next + end-code + + : ; 0 ?pairs compile unnest [compile] [ reveal ; + immediate restrict + + : Constant ( n -- ) Create , + ;Code ( -- n ) D push 2 W D) D mov Next end-code +( ----- 069 ) +\ uallot User Alias Defer ks 02 okt 87 + : uallot ( quan -- offset ) even dup udp @ + + $FF u> Abort" Userarea full" udp @ swap udp +! ; + + : User Create 2 uallot c, + ;Code ( -- addr ) D push 2 W D) D- mov + 0 # D+ mov U D add Next end-code + + : Alias ( cfa -- ) + Create last @ dup c@ $20 and + IF -2 allot ELSE $20 flag! THEN (name> ! ; + +| : crash true Abort" crash" ; + + : Defer Create ['] crash , + ;Code 2 W D) W mov W ) jmp end-code +( ----- 070 ) +\ vp current context also toss ks 02 okt 87 + + Create vp $10 allot + Variable current + + : context ( -- adr ) vp dup @ + 2+ ; + +| : thru.vocstack ( -- from to ) vp 2+ context ; + +\ "Only Forth also Assembler" gives +\ vp: countword = 6 | Root | Forth | Assembler | + + : also vp @ &10 > Error" Vocabulary stack full" + context @ 2 vp +! context ! ; + + : toss vp @ 0=exit -2 vp +! ; +( ----- 071 ) +\ Vocabulary Forth Only Onlyforth definitions ks 19 jun 88 + : Vocabulary Create 0 , 0 , here voc-link @ , voc-link ! + Does> context ! ; +\ | Name | Code | Thread | Coldthread | Voc-link | + + Vocabulary Forth +Host h' Transient 8 + @ T h' Forth 8 + H ! +Target Forth also definitions + + Vocabulary Root + + : Only vp off Root also ; + + : Onlyforth Only Forth also definitions ; + + : definitions context @ current ! ; +( ----- 072 ) +\ order vocs words ks 19 jun 88 +| : init-vocabularys voc-link @ + BEGIN dup 2- @ over 4- ! @ ?dup 0= UNTIL ; +| : .voc ( adr -- ) @ 2- >name .name ; + + : order vp 4+ context over umax + DO I .voc -2 +LOOP 2 spaces current .voc ; + + : vocs voc-link + BEGIN @ ?dup WHILE dup 6 - >name .name REPEAT ; + + : words ( -- ) [compile] Ascii capital >r context @ + BEGIN @ dup stop? 0= and + WHILE ?cr dup 2+ r@ bl = over 1+ c@ r@ = or + IF .name space ELSE drop THEN + REPEAT drop rdrop ; +( ----- 073 ) +\ (find found ks 09 jul 87 +| : found ( nfa -- cfa n ) dup c@ >r + (name> r@ $20 and IF @ THEN + -1 r@ $80 and IF 1- THEN + r> $40 and IF negate THEN ; + + Code (find ( string thread -- string ff / anf tf ) + D I xchg W pop D push W ) A- mov W inc + W D mov 0 # C+ mov $1F # A+ mov A+ A- and + [[ I ) I mov I I or 0= not + ?[[ 2 I D) C- mov A+ C- and A- C- cmp dup 0= ?] + I push D W mov 3 # I add + 0=rep byte cmps I pop 0= ?] + 3 # I add I W mov -1 # D mov + ][ D W mov 0 # D mov ]? W dec I pop W push Next + end-code +( ----- 074 ) +\\ -text (find ks 02 okt 87 + + : -text ( adr1 len adr2 -- 0< 1<2 / 0= 1=2 / 0> 1>2 ) + over bounds + DO drop count I c@ - dup IF LEAVE THEN LOOP nip ; + + : (find ( string thread -- str false / NFA +n ) + over c@ $1F and >r @ + BEGIN dup WHILE dup @ swap 2+ dup c@ $1F and r@ = + IF dup 1+ r@ 4 pick 1+ -text + 0= IF rdrop -rot drop exit + THEN THEN drop + REPEAT rdrop ; +( ----- 075 ) +\ find ' [compile] ['] nullstring? ks 29 oct 86 + + : find ( string -- acf n / string false ) + context dup @ over 2- @ = IF 2- THEN + BEGIN under @ (find IF nip found exit THEN + swap 2- dup vp = UNTIL drop false ; + + : ' ( -- cfa ) name find ?exit Error" ?" ; + + : [compile] ' , ; immediate restrict + + : ['] ' [compile] Literal ; immediate restrict + + : nullstring? ( string -- string false / true ) + dup c@ 0= dup 0=exit nip ; +( ----- 076 ) +\ interpreter ks 07 dez 87 + + Defer notfound + +| : interpreter ( string -- ) find ?dup + IF 1 and IF execute exit THEN + Error" compile only" + THEN number? ?exit notfound ; + +| : compiler ( string -- ) find ?dup + IF 0> IF execute exit THEN , exit THEN + number? ?dup IF 0> IF swap [compile] Literal THEN + [compile] Literal exit + THEN notfound ; +( ----- 077 ) +\ compiler [ ] ks 16 sep 88 + + : no.extensions ( string -- ) + state @ IF Abort" ?" THEN Error" ?" ; + + ' no.extensions Is notfound + + Defer parser ( string -- ) ' interpreter Is parser + + : interpret + BEGIN ?stack name nullstring? IF aborted off exit THEN + parser REPEAT ; + + : [ ['] interpreter Is parser state off ; immediate + + : ] ['] compiler Is parser state on ; +( ----- 078 ) +\ Is ks 07 dez 87 + + : (is r> dup 2+ >r @ ! ; + +| : def? ( cfa -- ) + @ [ ' notfound @ ] Literal - Abort" not deferred" ; + + : Is ( addr -- ) ' dup def? >body + state @ IF compile (is , exit THEN ! ; immediate +( ----- 079 ) +\ ?stack ks 01 okt 87 + +| : stackfull ( -- ) depth $20 > Abort" tight stack" + reveal last? IF dup heap? IF name> ELSE 4- THEN (forget THEN + true Abort" dictionary full" ; + + Code ?stack u' dp U D) A mov S A sub CS + ?[ $100 # A add CS ?[ ;c: stackfull ; Assembler ]? ]? + u' s0 U D) A mov A inc A inc S A sub + CS not ?[ Next ]? ;c: true Abort" stack empty" ; + +\ : ?stack sp@ here - $100 u< IF stackfull THEN +\ sp@ s0 @ u> Abort" stack empty" ; +( ----- 080 ) +\ .status push load ks 29 oct 86 + +| Create: pull r> r> ! ; + : push ( addr -- ) + r> swap dup >r @ >r pull >r >r ; restrict + + Defer .status ' noop Is .status + + : (load ( blk offset -- ) isfile@ >r + loadfile @ >r fromfile @ >r blk @ >r >in @ >r + >in ! blk ! isfile@ loadfile ! .status interpret + r> >in ! r> blk ! r> fromfile ! r> loadfile ! + r> isfile ! ; + + : load ( blk -- ) ?dup 0=exit 0 (load ; +( ----- 081 ) +\ +load thru +thru --> rdepth depth ks 26 jul 87 + + : +load ( offset -- ) blk @ + load ; + + : thru ( from to -- ) 1+ swap DO I load LOOP ; + + : +thru ( off0 off1 -- ) 1+ swap DO I +load LOOP ; + + : --> 1 blk +! >in off .status ; immediate + + : rdepth ( -- +n ) r0 @ rp@ 2+ - 2/ ; + + : depth ( -- +n ) sp@ s0 @ swap - 2/ ; +( ----- 082 ) +\ prompt quit ks 16 sep 88 + + : (prompt .status state @ IF cr ." ] " exit THEN + aborted @ 0= IF ." ok" THEN cr ; + + Defer prompt ' (prompt Is prompt + + : (quit BEGIN prompt query interpret REPEAT ; + + Defer 'quit ' (quit Is 'quit + + : quit r0 @ rp! [compile] [ blk off 'quit ; + +\ : classical cr .status state @ +\ IF ." C> " exit THEN ." I> " ; +( ----- 083 ) +\ end-trace abort ks 26 jul 87 + + : standardi/o [ output ] Literal output 4 cmove ; + + Code end-trace next-link # W mov $AD # A- mov + $FF97 # C mov [[ W ) W mov W W or 0= not + ?[[ A- -4 W D) mov C -3 W D) mov + ]]? lods A W xchg W ) jmp end-code + + Defer 'abort ' noop Is 'abort + + : abort end-trace clearstack 'abort standardi/o quit ; +( ----- 084 ) +\ (error Abort" Error" ks 16 sep 88 + Variable scr 1 scr ! + Variable r# r# off + + : (error ( string -- ) rdrop r> aborted ! standardi/o + space here .name count type space ?cr + blk @ ?dup IF scr ! >in @ r# ! THEN quit ; + ' (error errorhandler ! + + : (abort" "lit swap IF >r clearstack r> + errorhandler perform exit THEN drop ; restrict + +| : (error" "lit swap IF errorhandler perform exit THEN + drop ; restrict +( ----- 085 ) +\ -trailing space spaces ks 16 sep 88 + + : Abort" compile (abort" ," align ; immediate restrict + : Error" compile (error" ," align ; immediate restrict + + $20 Constant bl + + : -trailing ( addr n1 -- addr n2) + dup 0 ?DO 2dup + 1- c@ bl - IF LEAVE THEN 1- LOOP ; + + : space bl emit ; + : spaces ( u -- ) 0 ?DO space LOOP ; +( ----- 086 ) +\ hold <# #> sign # #s ks 29 dez 87 + +| : hld ( -- addr) pad 2- ; + + : hold ( char -- ) -1 hld +! hld @ c! ; + + : <# hld hld ! ; + + : #> ( 32b -- addr +n ) 2drop hld @ hld over - ; + + : sign ( n -- ) 0< not ?exit Ascii - hold ; + + : # ( +d1 -- +d2) + base @ ud/mod rot dup 9 > 7 and + Ascii 0 + hold ; + + : #s ( +d -- 0 0 ) BEGIN # 2dup d0= UNTIL ; +( ----- 087 ) +\ print numbers .s ks 07 feb 89 + + : d.r ( d +n -- ) -rot under dabs <# #s rot sign #> + rot over max over - spaces type ; + : d. ( d -- ) 0 d.r space ; + + : .r ( n +n -- ) swap extend rot d.r ; + : . ( n -- ) extend d. ; + + : u.r ( u +n -- ) 0 swap d.r ; + : u. ( u -- ) 0 d. ; + + : .s sp@ s0 @ over - $20 umin bounds ?DO I @ u. 2 +LOOP ; +( ----- 088 ) +\ list c/l l/s ks 19 m„r 88 + + &64 Constant c/l \ Screen line length + &16 Constant l/s \ lines per screen + + : list ( scr -- ) dup capacity u< + IF scr ! ." Scr " scr @ . + ." Dr " drv . isfile@ .file + l/s 0 DO cr I 2 .r space scr @ block + I c/l * + c/l -trailing type + LOOP cr exit + THEN 9 ?diskerror ; +( ----- 089 ) +\ multitasker primitives ks 29 oct 86 + + Code pause D push I push R push + S 6 U D) mov 2 U D) U add 4 # U add U jmp + end-code + + : lock ( addr -- ) + dup @ up@ = IF drop exit THEN + BEGIN dup @ WHILE pause REPEAT up@ swap ! ; + + : unlock ( addr -- ) dup lock off ; + + Label wake Assembler U pop 2 # U sub A pop + popf 6 U D) S mov R pop I pop D pop Next + end-code + $E9 4 * >label >taskINT +( ----- 090 ) +\\ Struktur der Blockpuffer ks 04 jul 87 + + 0 : link zum naechsten Puffer + 2 : file 0 = direct access + -1 = leer, + sonst adresse eines file control blocks + 4 : blocknummer + 6 : statusflags Vorzeichenbit kennzeichnet update + 8 : Data ... 1 Kb ... +( ----- 091 ) +\ buffer mechanism ks 04 okt 87 + + Variable isfile isfile off \ addr of file control block + Variable fromfile fromfile off \ fcb in kopieroperationen + + Variable prev prev off \ Listhead +| Variable buffers buffers off \ Semaphor + + $408 Constant b/buf \ physikalische Groesse + $400 Constant b/blk \ bytes/block + + Defer r/w \ physikalischer Diskzugriff + Variable error# error# off \ Nummer des letzten Fehlers + Defer ?diskerror \ Fehlerbehandlung +( ----- 092 ) +\ (core? ks 28 mai 87 + + Code (core? ( blk file -- dataaddr / blk file ) + A pop A push D D or 0= ?[ u' offset U D) A add ]? + prev #) W mov 2 W D) D cmp 0= + ?[ 4 W D) A cmp 0= + ?[ 8 W D) D lea A pop ' exit @ # jmp ]? ]? + [[ [[ W ) C mov C C or 0= ?[ Next ]? + C W xchg 4 W D) A cmp 0= ?] 2 W D) D cmp 0= ?] + W ) A mov prev #) D mov D W ) mov W prev #) mov + 8 W D) D lea C W mov A W ) mov A pop + ' exit @ # jmp + end-code +( ----- 093 ) +\\ (core? ks 31 oct 86 + +| : this? ( blk file bufadr -- flag ) + dup 4+ @ swap 2+ @ d= ; + + .( (core?: offset is handled differently in code! ) + +| : (core? ( blk file -- dataaddr / blk file ) + BEGIN over offset @ + over prev @ this? + IF rdrop 2drop prev @ 8 + exit THEN + 2dup >r offset @ + >r prev @ + BEGIN dup @ ?dup 0= IF rdrop rdrop drop exit THEN + dup r> r> 2dup >r >r rot this? 0= + WHILE nip REPEAT + dup @ rot ! prev @ over ! prev ! rdrop rdrop + REPEAT ; +( ----- 094 ) +\ backup emptybuf readblk ks 23 jul 87 + +| : backup ( bufaddr -- ) dup 6+ @ 0< + IF 2+ dup @ 1+ \ buffer empty if file = -1 + IF BEGIN dup 6+ over 2+ @ 2 pick @ 0 r/w + WHILE 1 ?diskerror REPEAT + THEN 4+ dup @ $7FFF and over ! THEN + drop ; + + : emptybuf ( bufaddr -- ) 2+ dup on 4+ off ; + +| : readblk ( blk file addr -- blk file addr ) + dup emptybuf >r + BEGIN 2dup 0= offset @ and + + over r@ 8 + -rot 1 r/w + WHILE 2 ?diskerror REPEAT r> ; +( ----- 095 ) +\ take mark updates? full? core? ks 04 jul 87 + +| : take ( -- bufaddr) prev + BEGIN dup @ WHILE @ dup 2+ @ -1 = UNTIL + buffers lock dup backup ; + +| : mark ( blk file bufaddr -- blk file ) 2+ >r + 2dup r@ ! over 0= offset @ and + r@ 2+ ! + r> 4+ off buffers unlock ; + +| : updates? ( -- bufaddr / flag) + prev BEGIN @ dup WHILE dup 6+ @ 0< UNTIL ; + + : core? ( blk file -- addr /false ) (core? 2drop false ; +( ----- 096 ) +\ block & buffer manipulation ks 01 okt 87 + + : (buffer ( blk file -- addr ) + BEGIN (core? take mark REPEAT ; + + : (block ( blk file -- addr ) + BEGIN (core? take readblk mark REPEAT ; + + Code isfile@ ( -- addr ) + D push isfile #) D mov Next end-code +\ : isfile@ ( -- addr ) isfile @ ; + + : buffer ( blk -- addr ) isfile@ (buffer ; + + : block ( blk -- addr ) isfile@ (block ; +( ----- 097 ) +\ block & buffer manipulation ks 02 okt 87 + + : update $80 prev @ 6+ 1+ ( Byte-Order! ) c! ; + + : save-buffers buffers lock + BEGIN updates? ?dup WHILE backup REPEAT buffers unlock ; + + : empty-buffers buffers lock prev + BEGIN @ ?dup WHILE dup emptybuf REPEAT buffers unlock ; + + : flush file-link + BEGIN @ ?dup WHILE dup fclose REPEAT + save-buffers empty-buffers ; +( ----- 098 ) +\ Allocating buffers ks 31 oct 86 + $10000 Constant limit Variable first + + : allotbuffer ( -- ) + first @ r0 @ - b/buf 2+ u< ?exit + b/buf negate first +! first @ dup emptybuf + prev @ over ! prev ! ; + + : freebuffer ( -- ) first @ limit b/buf - u< + IF first @ backup prev + BEGIN dup @ first @ - WHILE @ REPEAT + first @ @ swap ! b/buf first +! THEN ; + + : all-buffers BEGIN first @ allotbuffer first @ = UNTIL ; + +| : init-buffers prev off limit first ! all-buffers ; +( ----- 099 ) +\ endpoints of forget uh 27 apr 88 + +| : |? ( nfa -- flag ) c@ $20 and ; + +| : forget? ( adr nfa -- flag ) \ code in heap or above adr ? + name> under 1+ u< swap heap? or ; + +| : endpoint ( addr sym thread -- addr sym' ) + BEGIN BEGIN @ 2 pick over u> IF drop exit THEN + dup heap? UNTIL dup >r 2+ dup |? + IF >r over r@ forget? IF r@ (name> >body umax THEN + rdrop THEN r> + REPEAT ; + +| : endpoints ( addr -- addr symb ) heap voc-link @ + BEGIN @ ?dup WHILE dup >r 4- endpoint r> REPEAT ; +( ----- 100 ) +\ remove, -words, -tasks ks 30 apr 88 + : remove ( dic sym thread -- dic sym ) + BEGIN dup @ ?dup \ unlink forg. words + WHILE dup heap? + IF 2 pick over u> ELSE 3 pick over 1+ u< THEN + IF @ over ! ( unlink word) ELSE nip THEN REPEAT drop ; + +| : remove-words ( dic sym -- dic sym ) voc-link + BEGIN @ ?dup WHILE dup >r 4- remove r> REPEAT ; + +| : >up 2+ dup @ 2+ + ; + +| : remove-tasks ( dic -- ) up@ + BEGIN dup >up up@ - WHILE 2dup >up swap here uwithin + IF dup >up >up over - 2- 2- over 2+ ! ELSE >up THEN + REPEAT 2drop ; +( ----- 101 ) +\ remove-vocs trim ks 31 oct 86 + +| : remove-vocs ( dic symb -- dic symb ) + voc-link remove thru.vocstack + DO 2dup I @ -rot uwithin + IF [ ' Forth 2+ ] Literal I ! THEN -2 +LOOP + 2dup current @ -rot uwithin 0=exit + [ ' Forth 2+ ] Literal current ! ; + + Defer custom-remove ' noop Is custom-remove + + : trim ( dic symb -- ) next-link remove + over remove-tasks remove-vocs remove-words remove-files + custom-remove heap swap - hallot dp ! last off ; +( ----- 102 ) +\ deleting words from dict. ks 02 okt 87 + + : clear here dup up@ trim dp ! ; + + : (forget ( adr -- ) + dup heap? Abort" is symbol" endpoints trim ; + + : forget ' dup [ dp ] Literal @ u< Abort" protected" + >name dup heap? IF name> ELSE 4- THEN (forget ; + + : empty [ dp ] Literal @ up@ trim + [ udp ] Literal @ udp ! ; +( ----- 103 ) +\ save bye stop? ?cr ks 1UH 26sep88 + + : save here up@ trim up@ origin $100 cmove + voc-link @ BEGIN dup 4- @ over 2- ! @ ?dup 0= UNTIL ; + + $1B Constant #esc + +| : end? key #esc case? 0= + IF #cr case? 0= IF 3 ( Ctrl-C ) - ?exit THEN THEN + true rdrop ; + + : stop? ( -- flag ) key? IF end? end? THEN false ; + + : ?cr col c/l u> 0=exit cr ; +( ----- 104 ) +\ in/output structure ks 31 oct 86 + +| : Out: Create dup c, 2+ Does> c@ output @ + perform ; + + : Output: Create: Does> output ! ; +0 Out: emit Out: cr Out: type Out: del + Out: page Out: at Out: at? drop + + : row ( -- row ) at? drop ; + : col ( -- col ) at? nip ; + +| : In: Create dup c, 2+ Does> c@ input @ + perform ; + + : Input: Create: Does> input ! ; +0 In: key In: key? In: decode In: expect drop +( ----- 105 ) +\ Alias only definitionen ks 31 oct 86 + + Root definitions + + : seal [ ' Root >body ] Literal off ; \ "erases" Root Vocab. + + ' Only Alias Only + ' Forth Alias Forth + ' words Alias words + ' also Alias also + ' definitions Alias definitions + + Forth definitions +( ----- 106 ) +\ 'restart 'cold ks 01 sep 88 + + Defer 'restart ' noop Is 'restart + +| : (restart ['] (quit Is 'quit 'restart + [ errorhandler ] Literal @ errorhandler ! + ['] noop Is 'abort end-trace clearstack + standardi/o interpret quit ; + + Defer 'cold ' noop Is 'cold + +| : (cold origin up@ $100 cmove $80 count + $50 umin >r tib r@ move r> #tib ! >in off blk off + init-vocabularys init-buffers flush 'cold + Onlyforth page &24 spaces logo count type cr (restart ; +( ----- 107 ) +\ (boot ks 11 m„r 89 + + Label #segs ( -- R: seg ) Assembler + C: seg ' limit >body #) R mov R R or 0= not + ?[ 4 # C- mov R C* shr R inc ret ]? + $1000 # R mov ret + end-code + + Label (boot Assembler cli cld A A xor A D: mov + #segs # call C: D mov D R add R E: mov + $200 # C mov 0 # I mov I W mov rep movs + wake # >taskINT #) mov C: >taskINT 2+ #) mov + divovl # >divINT #) mov C: >divINT 2+ #) mov ret + end-code +( ----- 108 ) +\ restart ks 09 m„r 89 + + Label warmboot here >restart 2+ - >restart ! Assembler + (boot # call + here ' (restart >body # I mov + Label bootsystem + C: A mov A E: mov A D: mov A S: mov + s0 #) U mov 6 # U add u' s0 U D) S mov + D pop u' r0 U D) R mov sti Next + end-code + + Code restart here 2- ! end-code +( ----- 109 ) +\ bye ks 11 m„r 89 + + Variable return_code return_code off + +| Code (bye cli A A xor A E: mov #segs # call + C: D mov D R add R D: mov 0 # I mov I W mov + $200 # C mov rep movs sti \ restore interrupts + $4C # A+ mov C: seg return_code #) A- mov + $21 int warmboot # call + end-code + + : bye flush empty page (bye ; +( ----- 110 ) +\ cold ks 09 m„r 89 + + here >cold 2+ - >cold ! Assembler + (boot # call C: A mov A D: mov A E: mov + #segs # call $41 # R add \ another k for the ints + $4A # A+ mov $21 int \ alloc memory + CS ?[ $10 # return_code #) byte mov ' (bye @ # jmp ]? + here s0 #) W mov 6 # W add origin # I mov $20 # C mov + rep movs ' (cold >body # I mov bootsystem # jmp + end-code + + Code cold here 2- ! end-code +( ----- 111 ) +\ System patchup ks 16 sep 88 + + 1 &35 +thru \ MS-DOS interface + + : forth-83 ; \ last word in Dictionary + + 0 ' limit >body ! $DFF6 s0 ! $E77C r0 ! + s0 @ s0 2- ! here dp ! + + Host tudp @ Target udp ! + Host tvoc-link @ Target voc-link ! + Host tnext-link @ Target next-link ! + Host tfile-link @ Target Forth file-link ! + Host T move-threads H + save-buffers cr .( unresolved: ) .unresolved +( ----- 112 ) +\ lc@ lc! l@ l! special 8088 operators ks 27 oct 86 + + Code lc@ ( seg:addr -- 8b ) D: pop D W mov + W ) D- mov 0 # D+ mov C: A mov A D: mov Next + end-code + + Code lc! ( 8b seg:addr -- ) D: pop A pop D W mov + A- W ) mov C: A mov A D: mov D pop Next end-code + + Code l@ ( seg:addr -- 16b ) D: pop D W mov + W ) D mov C: A mov A D: mov Next end-code + + Code l! ( 16b seg:addr -- ) D: pop A pop D W mov + A W ) mov C: A mov A D: mov D pop Next end-code +( ----- 113 ) +\ ltype lmove special 8088 operators ks 11 dez 87 + + : ltype ( seg:addr len -- ) + 0 ?DO 2dup I + lc@ emit LOOP 2drop ; + + Code lmove ( from.seg:addr to.seg:addr quan -- ) + A I xchg D C mov W pop E: pop + I pop D: pop I W cmp CS + ?[ rep byte movs + ][ C dec C W add C I add C inc + std rep byte movs cld + ]? A I xchg C: A mov A E: mov + A D: mov D pop Next end-code +( ----- 114 ) +\ BDOS keyboard input ks 16 sep 88 +\ es muss wirklich so kompliziert sein, da sonst kein ^C und ^P +\\ +| Variable newkey newkey off + + Code (key@ ( -- 8b ) D push newkey #) D mov D+ D+ or + 0= ?[ $7 # A+ mov $21 int A- D- mov ]? + 0 # D+ mov D+ newkey 1+ #) mov Next + end-code + + Code (key? ( -- f ) D push newkey #) D mov D+ D+ or + 0= ?[ -1 # D- mov 6 # A+ mov $21 int 0= + ?[ 0 # D+ mov + ][ -1 # A+ mov A newkey #) mov -1 # D+ mov + ]? ]? D+ D- mov Next + end-code +( ----- 115 ) +\ empty-keys (key ks 16 sep 88 +\\ + Code empty-keys $C00 # A mov $21 int + 0 # newkey 1+ #) byte mov Next end-code + + : (key ( -- 16b ) BEGIN pause (key? UNTIL + (key@ ?dup ?exit (key? IF (key@ negate exit THEN 0 ; +( ----- 116 ) +\ BIOS keyboard input ks 16 sep 88 + + Code (key@ ( -- 8b ) D push A+ A+ xor $16 int + A- D- xchg 0 # D+ mov Next end-code + + Code (key? ( -- f ) D push 1 # A+ mov D D xor + $16 int 0= not ?[ D dec ]? Next end-code + + Code empty-keys $C00 # A mov $21 int Next end-code + + : (key ( -- 8b ) BEGIN pause (key? UNTIL (key@ ; + +\ mit diesen Keytreibern sind die Funktionstasten nicht +\ mehr durch ANSI.SYS Sequenzen vorbelegt. +( ----- 117 ) +\ (decode expect ks 16 sep 88 + + 7 Constant #bel 8 Constant #bs + 9 Constant #tab $A Constant #lf + $D Constant #cr + + : (decode ( addr pos1 key -- addr pos2 ) + #bs case? IF dup 0=exit del 1- exit THEN + #cr case? IF dup span ! space exit THEN + >r 2dup + r@ swap c! r> emit 1+ ; + + : (expect ( addr len1 -- ) span ! 0 + BEGIN dup span @ u< WHILE key decode REPEAT 2drop ; + + Input: keyboard [ here input ! ] + (key (key? (decode (expect [ drop +( ----- 118 ) +\ MSDOS character output ks 29 jun 87 + + Code charout ( char -- ) $FF # D- cmp 0= ?[ D- dec ]? + 6 # A+ mov $21 int D pop ' pause # W mov W ) jmp + end-code + + &80 Constant c/row &25 Constant c/col + + : (emit ( char -- ) dup bl u< IF $80 or THEN charout ; + : (cr #cr charout #lf charout ; + : (del #bs charout bl charout #bs charout ; + : (at 2drop ; + : (at? 0 0 ; + : (page c/col 0 DO cr LOOP ; +( ----- 119 ) +\ MSDOS character output ks 7 may 85 + + : bell #bel charout ; + + : tipp ( addr len -- ) bounds ?DO I c@ emit LOOP ; + + Output: display [ here output ! ] + (emit (cr tipp (del (page (at (at? [ drop +( ----- 120 ) +\ MSDOS printer I/O Port access ks 09 aug 87 + + Code lst! ( 8b -- ) $5 # A+ mov $21 int D pop Next + end-code + + Code pc@ ( port -- 8b ) + D byte in A- D- mov D+ D+ xor Next + end-code + + Code pc! ( 8b port -- ) + A pop D byte out D pop Next + end-code +( ----- 121 ) +\ zero terminated strings ks 09 aug 87 + + : counted ( asciz -- addr len ) + dup -1 0 scan drop over - ; + + : >asciz ( string addr -- asciz ) 2dup >r - + IF count r@ place r@ THEN 0 r> count + c! 1+ ; + + + + : asciz ( -- asciz ) name here >asciz ; +( ----- 122 ) +\ Disk capacities ks 08 aug 88 + Vocabulary Dos Dos also definitions + + 6 Constant #drives + + Create capacities $4B0 , $4B0 , $1B31 , $1B31 , $1B0F , 0 , + +| Code ?capacity ( +n -- cap ) D shl capacities # W mov + D W add W ) D mov Next end-code +( ----- 123 ) +\ MS-dos disk handlers direct access ks 31 jul 87 + +| Code block@ ( addr blk drv -- ff ) + D- A- mov D pop C pop R push U push + I push C R mov 2 # C mov D shl $25 int + Label end-r/w I pop I pop U pop R pop 0 # D mov + CS ?[ D+ A+ mov A error# #) mov D dec ]? Next + end-code + +| Code block! ( addr blk drv -- ff ) D- A- mov D pop + C pop R push U push I push C R mov 2 # C mov + D shl $26 int end-r/w # jmp + end-code +( ----- 124 ) +\ MS-dos disk handlers direct access ks cas 18jul20 + +| : ?drive ( +n -- +n ) dup #drives u< ?exit + Error" beyond drive capacity" ; + + : /drive ( blk1 -- blk2 drive ) 0 swap #drives 0 + DO dup I ?capacity under u< IF drop LEAVE THEN + - swap 1+ swap LOOP swap ; + + : blk/drv ( -- capacity ) drv ?capacity ; + + Forth definitions + + : >drive ( blk1 +n -- blk2 ) ?drive + 0 swap drv 2dup u> dup >r 0= IF swap THEN + ?DO I ?capacity + LOOP r> IF negate THEN - ; +( ----- 125 ) +\ MS-DOS file access ks 18 m„r 88 + Dos definitions + +| Variable fcb fcb off \ last fcb accessed +| Variable prevfile \ previous active file + + &30 Constant fnamelen \ default length in FCB + + Create filename &62 allot \ max 60 + count + null + + Variable attribut 7 attribut ! \ read-only, hidden, system +( ----- 126 ) +\ MS-DOS disk errors ks cas 18jul20 + +| : .error# ." error # " base push decimal error# @ . ; + +| : .ferrors error# @ &18 case? IF 2 THEN + 1 case? Abort" file exists" + 2 case? Abort" file not found" + 3 case? Abort" path not found" + 4 case? Abort" too many open files" + 5 case? Abort" no access" + 9 case? Abort" beyond end of file" + &15 case? Abort" illegal drive" + &16 case? Abort" current directory" + &17 case? Abort" wrong drive" + drop ." Disk" .error# abort ; +( ----- 127 ) +\ MS-DOS disk errors ks cas 18jul20 + + : (diskerror ( *f -- ) ?dup 0=exit + fcb @ IF error# ! .ferrors exit THEN + input push output push standardi/o 1- + IF ." read" ELSE ." write" THEN + .error# ." retry? (y/n)" + key cr capital Ascii Y = not Abort" aborted" ; + + ' (diskerror Is ?diskerror +( ----- 128 ) +\ ~open ~creat ~close ks 04 aug 87 + + Code ~open ( asciz mode -- handle ff / err# ) + A D xchg $3D # A+ mov + Label >open D pop $21 int A D xchg + CS not ?[ D push 0 # D mov ]? Next + end-code + + Code ~creat ( asciz attribut -- handle ff / err# ) + D C mov $3C # A+ mov >open ]] end-code + + Code ~close ( handle -- ) D R xchg + $3E # A+ mov $21 int R D xchg D pop Next + end-code +( ----- 129 ) +\ ~first ~unlink ~select ~disk? ks 04 aug 87 + + Code ~first ( asciz attr -- err# ) + D C mov D pop $4E # A+ mov + [[ $21 int 0 # D mov CS ?[ A D xchg ]? Next + end-code + + Code ~unlink ( asciz -- err# ) $41 # A+ mov ]] end-code + + Code ~select ( n -- ) + $E # A+ mov $21 int D pop Next end-code + + Code ~disk? ( -- n ) D push $19 # A+ mov + $21 int A- D- mov 0 # D+ mov Next + end-code +( ----- 130 ) +\ ~next ~dir ks 04 aug 87 + + Code ~next ( -- err# ) D push $4F # A+ mov + $21 int 0 # D mov CS ?[ A D xchg ]? Next + end-code + + Code ~dir ( addr drive -- err# ) I W mov + I pop $47 # A+ mov $21 int W I mov + 0 # D mov CS ?[ A D xchg ]? Next + end-code +( ----- 131 ) +\ MS-DOS file control Block cas 19jun20 + +| : Fcbytes ( n1 len -- n2 ) Create over c, + + Does> ( fcbaddr -- fcbfield ) c@ + ; + +\ first field for file-link +2 1 Fcbytes f.no \ must be first field + 2 Fcbytes f.handle + 2 Fcbytes f.date + 2 Fcbytes f.time + 4 Fcbytes f.size + fnamelen Fcbytes f.name Constant b/fcb + +b/fcb Host ' tb/fcb >body ! + Target Forth also Dos also definitions +( ----- 132 ) +\ (.file fname fname! ks 10 okt 87 + + : fname! ( string fcb -- ) f.name >r count + dup fnamelen < not Abort" file name too long" r> place ; + +| : filebuffer? ( fcb -- fcb bufaddr / fcb ff ) + prev BEGIN @ dup WHILE 2dup 2+ @ = UNTIL ; + +| : flushfile ( fcb -- ) + BEGIN filebuffer? ?dup + WHILE dup backup emptybuf REPEAT drop ; + + : fclose ( fcb -- ) ?dup 0=exit + dup f.handle @ ?dup 0= IF drop exit THEN + over flushfile ~close f.handle off ; +( ----- 133 ) +\ (.file fname fname! ks 18 m„r 88 + +| : getsize ( -- d ) [ $80 &26 + ] Literal 2@ swap ; + + : (fsearch ( string -- asciz *f ) + filename >asciz dup attribut @ ~first ; + + Defer fsearch ( string -- asciz *f ) + + ' (fsearch Is fsearch + +\ graceful behaviour if file does not exist +| : ?notfound ( f* -- ) ?dup 0=exit last' @ [fcb] = + IF hide file-link @ @ file-link ! prevfile @ setfiles + last @ 4 - dp ! last off filename count here place + THEN ?diskerror ; +( ----- 134 ) +\ freset fseek ks 19 m„r 88 + + : freset ( fcb -- ) ?dup 0=exit + dup f.handle @ ?dup IF ~close THEN dup >r + f.name fsearch ?notfound getsize r@ f.size 2! + [ $80 &22 + ] Literal @ r@ f.time ! + [ $80 &24 + ] Literal @ r@ f.date ! + 2 ~open ?diskerror r> f.handle ! ; + + + Code fseek ( dfaddr fcb -- ) + D W mov u' f.handle W D) W mov W W or 0= + ?[ ;c: dup freset fseek ; Assembler ]? R W xchg + C pop D pop $4200 # A mov $21 int W R mov + CS not ?[ D pop Next ]? A D xchg ;c: ?diskerror ; +( ----- 135 ) +\ lfgets fgetc file@ ks 07 jul 88 + +\ Code ~read ( seg:addr quan handle -- #read ) D W mov +Assembler [[ W R xchg C pop D pop + D: pop $3F # A+ mov $21 int C: C mov C D: mov + W R mov A D xchg CS not ?[ Next ]? ;c: ?diskerror ; + + Code lfgets ( seg:addr quan fcb -- #read ) + D W mov u' f.handle W D) W mov ]] end-code + + true Constant eof + + : fgetc ( fcb -- 8b / eof ) + >r 0 sp@ ds@ swap 1 r> lfgets ?exit 0= ; + + : file@ ( dfaddr fcb -- 8b / eof ) dup >r fseek r> fgetc ; +( ----- 136 ) +\ lfputs fputc file! ks 24 jul 87 + +| Code ~write ( seg:addr quan handle -- ) D W mov +[[ W R xchg C pop D pop + D: pop $40 # A+ mov $21 int W R mov A D xchg + C: W mov W D: mov CS ?[ ;c: ?diskerror ; Assembler ]? + C D sub 0= ?[ D pop Next ]? ;c: Abort" Disk voll" ; + + Code lfputs ( seg:addr quan fcb -- ) + D W mov u' f.handle W D) W mov ]] end-code + + : fputc ( 8b fcb -- ) >r sp@ ds@ swap 1 r> lfputs drop ; + + : file! ( 8b dfaddr fcb -- ) dup >r fseek r> fputc ; +( ----- 137 ) +\ /block *block ks 02 okt 87 + + Code /block ( d -- rest blk ) A D xchg C pop + C D mov A shr D rcr A shr D rcr D+ D- mov + A- D+ xchg $3FF # C and C push Next + end-code +\ : /block ( d -- rest blk ) b/blk um/mod ; + + Code *block ( blk -- d ) A A xor D+ D- xchg D+ A+ xchg + A+ sal D rcl A+ sal D rcl A push Next + end-code +\ : *block ( blk -- d ) b/blk um* ; +( ----- 138 ) +\ fblock@ fblock! ks 19 m„r 88 + Dos definitions + +| : ?beyond ( blk -- blk ) dup 0< 0=exit 9 ?diskerror ; + +| : fblock ( addr blk fcb -- seg:addr quan fcb ) + fcb ! ?beyond dup *block fcb @ fseek ds@ -rot + fcb @ f.size 2@ /block rot - ?beyond + IF drop b/blk THEN fcb @ ; + + : fblock@ ( addr blk fcb -- ) fblock lfgets drop ; + + : fblock! ( addr blk fcb -- ) fblock lfputs ; +( ----- 139 ) +\ (r/w flush ks 18 m„r 88 + Forth definitions + + : (r/w ( addr blk fcb r/wf -- *f ) over fcb ! over + IF IF fblock@ false exit THEN fblock! false exit + THEN >r drop /drive ?drive + r> IF block@ exit THEN block! ; + + ' (r/w Is r/w + +| : setfiles ( fcb -- ) isfile@ prevfile ! + dup isfile ! fromfile ! ; + + : direct 0 setfiles ; +( ----- 140 ) +\ File >file ks 23 m„r 88 + + : File Create file-link @ here file-link ! , + here [ b/fcb 2 - ] Literal dup allot erase + file-link @ dup @ f.no c@ 1+ over f.no c! + last @ count $1F and rot f.name place + Does> setfiles ; + + File kernel.scr ' kernel.scr @ Constant [fcb] + + Dos definitions + + : .file ( fcb -- ) + ?dup IF body> >name .name exit THEN ." direct" ; +( ----- 141 ) +\ .file pushfile close open ks 12 mai 88 + Forth definitions + + : file? isfile@ .file ; + + : pushfile r> isfile push fromfile push >r ; restrict + + : close isfile@ fclose ; + + : open isfile@ freset ; + + : assign isfile@ dup fclose name swap fname! open ; +( ----- 142 ) +\ use from loadfrom include ks 18 m„r 88 + + : use >in @ name find + 0= IF swap >in ! File last' THEN nip + dup @ [fcb] = over ['] direct = or + 0= Abort" not a file" execute open ; + + : from isfile push use ; + + : loadfrom ( n -- ) pushfile use load close ; + + : include 1 loadfrom ; +( ----- 143 ) +\ drive drv capacity drivenames ks 18 m„r 88 + + : drive ( n -- ) isfile@ IF ~select exit THEN + ?drive offset off 0 ?DO I ?capacity offset +! LOOP ; + + : drv ( -- n ) + isfile@ IF ~disk? exit THEN offset @ /drive nip ; + + : capacity ( -- n ) isfile@ ?dup + IF dup f.handle @ 0= IF dup freset THEN + f.size 2@ /block swap 0<> - exit THEN blk/drv ; + +| : Drv: Create c, Does> c@ drive ; + + 0 Drv: A: 1 Drv: B: 2 Drv: C: 3 Drv: D: + 4 Drv: E: 5 Drv: F: 6 Drv: G: 7 Drv: H: +( ----- 144 ) +\ lfsave savefile savesystem ks 10 okt 87 + + : lfsave ( seg:addr quan string -- ) + filename >asciz 0 ~creat ?diskerror + dup >r ~write r> ~close ; + + : savefile ( addr len -- ) ds@ -rot + name nullstring? Abort" needs name" lfsave ; + + : savesystem save flush $100 here savefile ; +( ----- 145 ) +\ viewing ks 19 m„r 88 + Dos definitions +| $400 Constant viewoffset + + : (makeview ( -- n ) + blk @ dup 0=exit loadfile @ ?dup 0=exit f.no c@ ?dup + IF viewoffset * + $8000 or exit THEN 0= ; + ' (makeview Is makeview + + : @view ( acf -- blk fno ) >name 4 - @ dup 0< + IF $7FFF and viewoffset u/mod exit THEN + ?dup 0= Error" eingetippt" 0 ; + + : >file ( fno -- fcb ) dup 0=exit file-link + BEGIN @ dup WHILE 2dup f.no c@ = UNTIL nip ; +( ----- 146 ) +\ forget FCB's ks 23 okt 88 + Forth definitions +| : 'file ( -- scr ) r> scr push isfile push >r + [ Dos ] ' @view >file isfile ! ; + + : view 'file list ; + : help 'file capacity 2/ + list ; + +| : remove? ( dic symb addr -- dic symb addr f ) + 2 pick over 1+ u< ; + +| : remove-files ( dic symb -- dic symb ) file-link + BEGIN @ ?dup WHILE remove? IF dup fclose THEN REPEAT + file-link remove + isfile@ remove? nip IF file-link @ isfile ! THEN + fromfile @ remove? nip 0=exit isfile@ fromfile ! ; +( ----- 147 ) +\ BIOS keyboard input ks 16 sep 88 + + Code (key@ ( -- 8b ) D push A+ A+ xor $16 int + 0 # D+ mov A- D- mov A- A- or + 0= ?[ A+ D- mov D+ com ]? Next end-code + + : test BEGIN (key@ #esc case? ?exit + cr dup emit 5 .r key 5 .r REPEAT ; +\\ + Code (key? ( -- f ) D push 1 # A+ mov D D xor + $16 int 0= not ?[ D dec ]? Next end-code + + Code empty-keys $C00 # A mov $21 int Next end-code + + : (key ( -- 8b ) BEGIN pause (key? UNTIL (key@ ; diff --git a/8086/pc-baremetal/meta.fth b/8086/pc-baremetal/meta.fth new file mode 100644 index 0000000..9c31d34 --- /dev/null +++ b/8086/pc-baremetal/meta.fth @@ -0,0 +1,545 @@ +( ----- 001 ) +\ Target compiler loadscr ks cas 09jun20 + Onlyforth \needs Assembler 2 loadfrom asm.fb + + : c+! ( 8b addr -- ) dup c@ rot + swap c! ; + + ' find $22 + @ Alias found + + : search ( string 'vocab -- acf n / string ff ) + dup @ [ ' Forth @ ] Literal - Abort" no vocabulary" + >body (find IF found exit THEN false ; + + 3 &27 thru Onlyforth savesystem meta.com + +cr .( Metacompiler saved as META.COM ) +( ----- 002 ) +\ Predefinitions loadscreen ks 30 apr 88 + + &28 load + +cr .( Predefinitions geladen ...) cr +( ----- 003 ) +\ Target header pointers ks 29 jun 87 + + Variable tfile tfile off \ handle of target file + Variable tdp tdp off \ target dp + Variable displace displace off \ diplacement of code + Variable ?thead ?thead off \ for headerless code + Variable tlast tlast off \ last name in target + Variable glast' glast' off \ acf of latest ghost + Variable tdoes> tdoes> off \ code addr of last does + Variable tdodo tdodo off \ location of dodo + Variable >in: >in: off \ last :-def + Variable tvoc tvoc off \ + Variable tvoc-link tvoc-link off \ voc-link in target + Variable tnext-link tnext-link off \ link for tracer +( ----- 004 ) +\ Target header pointers ks 10 okt 87 + + : there ( -- taddr ) tdp @ ; + + : new pushfile makefile isfile@ tfile ! + tvoc-link off tnext-link off + $100 tdp ! $100 displace ! ; +( ----- 005 ) +\ Ghost-creating ks 07 dez 87 + +0 | Constant 0 | Constant + +| Create gname $21 allot + +| : >heap ( from quan -- ) \ heap over - 1 and + \ align + dup hallot heap swap cmove ; + + : symbolic ( string -- cfa.ghost ) + count dup 1 $1F uwithin not Abort" invalid Gname" + gname place BL gname append align here >r makeview , + state @ IF context ELSE current THEN @ @ dup @ , + gname count under here place 1+ allot align + here r@ - , 0 , 0 , r@ here over - >heap + heap 2+ rot ! r> dp ! heap + ; +( ----- 006 ) +\ ghost words ks 07 dez 87 + + : gfind ( string -- cfa tf / string ff ) + >r 1 r@ c+! r@ find -1 r> c+! ; + + : ghost ( -- cfa ) name gfind ?exit symbolic ; + + : gdoes> ( cfa.ghost -- cfa.does ) + 4 + dup @ IF @ exit THEN + here , 0 , dup 4 >heap + dp ! heap swap ! heap ; +( ----- 007 ) +\ ghost utilities ks 29 jun 87 + + : g' ( -- acf ) name gfind 0= Abort" ?T?" ; + + : '. g' dup @ case? + IF ." forw" ELSE - Abort" ??" ." res" THEN + 2+ dup @ 5 u.r 2+ @ ?dup + IF dup @ case? + IF ." fdef" ELSE - Abort" ??" ." rdef" THEN + 2+ @ 5 u.r THEN ; + + ' ' Alias h' +( ----- 008 ) +\ .unresolved ks 29 jun 87 + +| : forward? ( cfa -- cfa / exit&true ) + dup @ = 0=exit dup 2+ @ 0=exit drop true rdrop ; + +| : unresolved? ( addr -- f ) 2+ + dup count $1F and + 1- c@ bl = + IF name> forward? 4+ @ dup IF forward? THEN + THEN drop false ; + +| : unresolved-words ( thread -- ) + BEGIN @ ?dup WHILE dup unresolved? + IF dup 2+ .name ?cr THEN REPEAT ; + + : .unresolved voc-link @ + BEGIN dup 4 - unresolved-words @ ?dup 0= UNTIL ; +( ----- 009 ) +\ Extending Vocabularys for Target-Compilation ks 29 jun 87 + + Vocabulary Ttools + Vocabulary Defining + + : Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ; + + Vocabulary Transient tvoc off + + Root definitions + + : T Transient ; immediate + : H Forth ; immediate + : D Defining ; immediate + + Forth definitions +( ----- 010 ) +\ Image and byteorder ks 02 jul 87 + +| Code >byte ( 16b -- 8b- 8b+ ) A A xor + D- A- xchg D+ D- xchg A push Next end-code + +| Code byte> ( 8b- 8b+ -- 16b ) + A pop D- D+ mov A- D- xchg Next end-code + +| : >target ( addr1 -- daddr fcb ) displace @ - 0 tfile @ ; + + Transient definitions + + : c@ ( addr -- 8b ) [ Dos ] + >target file@ dup 0< Abort" nie abgespeichert" ; + + : c! ( 8b addr -- ) [ Dos ] >target file! ; +( ----- 011 ) +\ Transient primitives ks 09 jul 87 + : @ ( addr -- n ) H dup T c@ swap 1+ c@ byte> ; + : ! ( n addr -- ) H >r >byte r@ 1+ T c! r> c! H ; + + : cmove ( from.mem to.target quan -- ) [ Dos ] + >r >target fseek ds@ swap r> tfile @ lfputs ; +\ bounds ?DO dup c@ I T c! H 1+ LOOP drop ; + + : here ( -- taddr ) H tdp @ ; + : here! ( taddr -- ) H tdp ! ; + : allot ( n -- ) H tdp +! ; + : c, ( 8b -- ) T here c! 1 allot H ; + : , ( 16b -- ) T here ! 2 allot H ; + : align ( -- ) H ; immediate + : even ( addr1 -- addr2 ) H ; immediate + : halign H ; immediate +( ----- 012 ) +\ Transient primitives ks 29 jun 87 + + : count ( addr1 -- addr2 len ) H dup 1+ swap T c@ H ; + + : ," H here ," here over dp ! + over - T here swap dup allot cmove H ; + + : fill ( addr quan 8b -- ) H + -rot bounds ?DO dup I T c! H LOOP drop ; + : erase ( addr quan -- ) H 0 T fill H ; + : blank ( addr quan -- ) H bl T fill H ; + + : move-threads H tvoc @ tvoc-link @ + BEGIN over ?dup + WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT + Error" some undef. Target-Vocs left" drop ; +( ----- 013 ) +\ Resolving ks 29 jun 87 + Forth definitions + + : resolve ( cfa.ghost cfa.target -- ) over dup @ = + IF space dup >name .name ." exists " ?cr + 2+ ! drop exit THEN >r >r 2+ @ ?dup + IF BEGIN dup T @ H 2dup = Abort" resolve loop" + r@ rot T ! H ?dup 0= UNTIL + THEN r> r> over ! 2+ ! ; + + : resdoes> ( acf.ghost acf.target -- ) swap gdoes> + dup @ = IF 2+ ! exit THEN swap resolve ; + +here 2+ 0 ] Does> dup @ there rot ! T , H ; ' >body ! +here 2+ 0 ] Does> @ T , H ; ' >body ! +( ----- 014 ) +\ compiling names into targ. ks 10 okt 87 + +| : tlatest ( -- addr ) current @ 6 + ; + + : (theader ?thead @ IF 1 ?thead +! exit THEN + >in @ bl word swap >in ! dup count upper + dup c@ 1 $20 uwithin not Abort" inval. Tname" + blk @ $8400 or T align , H + there tlatest @ T , H tlatest ! there tlast ! + there over c@ 1+ dup T allot cmove align H ; + + : theader tlast off + (theader ghost dup glast' ! there resolve ; +( ----- 015 ) +\ prebuild defining words ks 29 jun 87 + +| : (prebuild >in @ Create >in ! + r> dup 2+ >r @ here 2- ! ; + +| : tpfa, there , ; + + : prebuild ( addr check# -- check# ) 0 ?pairs + dup IF compile (prebuild dup , THEN + compile theader ghost gdoes> , + IF compile tpfa, THEN 0 ; immediate + + : dummy 0 ; + + : DO> [compile] Does> here 3 - compile @ 0 ] ; +( ----- 016 ) +\ Constructing defining words in Host kks 07 dez 87 + +| : defcomp ( string -- ) dup ['] Defining search ?dup + IF 0> IF nip execute exit THEN drop dup THEN + find ?dup IF 0< IF nip , exit THEN THEN + drop ['] Forth search ?dup + IF 0< IF , exit THEN execute exit THEN + number? ?dup 0= Abort" ?" + 0> IF swap [compile] Literal THEN [compile] Literal ; + +| : definter ( string -- ) dup ['] Defining search ?dup + IF 0< IF nip execute exit THEN THEN drop + find ?dup IF 1 and 0= Abort" compile only" execute exit + THEN number? 0= Error" ?" ; +( ----- 017 ) +\ Constructing defining words in Host ks 22 dez 87 + +| : (;tcode r> @ tlast @ T count + ! H ; + +Defining definitions + + : ] H ] ['] defcomp Is parser ; + + : [ H [compile] [ ['] definter Is parser ; immediate + + : ; H [compile] ; [compile] \\ ; immediate + + : Does> H compile (;tcode tdoes> @ , + [compile] ; -2 allot [compile] \\ ; immediate +D ' Does> Alias ;Code immediate H +( ----- 018 ) +\ reinterpreting defining words ks 22 dez 87 + Forth definitions + + : ?reinterpret ( f -- ) 0=exit + state @ >r >in @ >r adr parser @ >r + >in: @ >in ! : D ] H interpret + r> Is parser r> >in ! r> state ! ; + + : undefined? ( -- f ) glast' @ 4+ @ 0= ; + +| : flag! ( 8b -- ) tlast @ ?dup 0= IF drop exit THEN + dup T c@ rot or swap c! H ; + +| : nfa? ( acf alf -- anf / acf ff ) + BEGIN dup WHILE 2dup 2+ T count $1F and + even H = + IF 2+ nip exit THEN T @ H REPEAT ; +( ----- 019 ) +\ the 8086 Assembler ks 29 jun 87 + +| Create relocate ] T c, , here ! c! H [ + +Transient definitions + + : Assembler H [ Assembler ] relocate >codes ! Assembler ; + + : >label ( 16b -- ) H >in @ name gfind rot >in ! + IF over resolve dup THEN drop Constant ; + + : Label T here >label Assembler H ; + + : Code H theader T here 2+ , Assembler H ; +( ----- 020 ) +( Transient primitives ks 17 dec 83 ) + +' exit Alias exit ' load Alias load +' / Alias / ' thru Alias thru +' swap Alias swap ' * Alias * +' dup Alias dup ' drop Alias drop +' /mod Alias /mod ' rot Alias rot +' -rot Alias -rot ' over Alias over +' 2* Alias 2* ' + Alias + +' - Alias - ' 1+ Alias 1+ +' 2+ Alias 2+ ' 1- Alias 1- +' 2- Alias 2- ' negate Alias negate +' 2swap Alias 2swap ' 2dup Alias 2dup +( ----- 021 ) +\ Transient primitives kks 29 jun 87 + + ' also Alias also ' words Alias words +' definitions Alias definitions ' hex Alias hex +' decimal Alias decimal ' ( Alias ( immediate + ' \ Alias \ immediate ' \\ Alias \\ immediate + ' .( Alias .( immediate ' [ Alias [ immediate + ' cr Alias cr +' end-code Alias end-code ' Transient Alias Transient + ' +thru Alias +thru ' +load Alias +load + ' .s Alias .s + +Tools ' trace Alias trace immediate +( ----- 022 ) +\ immediate words and branch primitives ks 29 jun 87 + + : >mark ( -- addr ) T here 0 , H ; + : >resolve ( addr -- ) T here over - swap ! H ; + : name ks 29 jun 87 + + : ' ( -- acf ) H g' dup @ - + IF Error" undefined" THEN 2+ @ ; + + : compile H ghost , ; immediate restrict + + : >name ( acf -- anf / ff ) H tvoc + BEGIN @ dup WHILE under 2- @ nfa? ?dup IF nip exit THEN + swap REPEAT nip ; +( ----- 024 ) +\ >name Alias ks 29 jun 87 + + : >body ( acf -- apf ) H 2+ ; + + : Alias ( n -- ) H tlast off + (theader ghost over resolve T , H $20 flag! ; + + : on ( addr -- ) H true swap T ! H ; + : off ( addr -- ) H false swap T ! H ; +( ----- 025 ) +\ Target tools ks 9 sep 86 + Onlyforth + +| : .tfield ( taddr len quan -) >r under Pad swap + bounds ?DO dup T c@ I H c! 1+ LOOP drop + Pad over type r> swap - 0 max spaces ; + + ' view Alias hview + + Ttools also definitions + +| : ?: ( addr -- addr ) dup 4 u.r ." :" ; +| : @? ( addr -- addr ) dup T @ H 6 u.r ; +| : c? ( addr -- addr ) dup T c@ H 3 .r ; +( ----- 026 ) +\ Ttools for decompiling ks 9 sep 86 + + : s ( addr -- addr+ ) ?: space c? 4 spaces + T count 2dup + even -rot 18 .tfield ; + + : n ( addr -- addr+2 ) ?: @? 2 spaces dup T @ >name H + ?dup IF T count H ELSE 0 0 THEN + $1F and $18 .tfield 2+ ; + + : d ( addr n -- addr+n ) 2dup swap ?: 3 spaces + swap 0 DO c? 1+ LOOP 4 spaces -rot dup .tfield ; + + : l ( addr -- addr+2 ) ?: 6 spaces @? 2+ 14 spaces ; + + : c ( addr -- addr+1 ) 1 d 15 spaces ; +( ----- 027 ) +\ Tools for decompiling ks 29 jun 87 + + : b ( addr -- addr+2 ) ?: @? dup T @ H + over + 6 u.r 2+ 14 spaces ; + + : dump ( addr n -- ) + bounds ?DO cr I 10 d drop stop? IF LEAVE THEN 10 +LOOP ; + + : view T ' >name H ?dup 0=exit 4 - T @ H ?dup 0=exit edit ; +( ----- 028 ) +\ Predefinitions loadscreen ks 29 jun 87 + Onlyforth + + : clear H true Abort" There are ghosts" ; + + + 1 $B +thru +( ----- 029 ) +\ Literal ['] ?" ." " ks 29 jun 87 + Transient definitions Forth + + : Literal ( n -- ) H dup $FF00 and + IF T compile lit , H exit THEN T compile clit c, H ; + immediate + + : Ascii H bl word 1+ c@ state @ 0=exit + T [compile] Literal H ; immediate + + : ['] T compile lit H ; immediate + : ." T compile (." ," align H ; immediate + : " T compile (" ," align H ; immediate +( ----- 030 ) +\ Target compilation ] ks 07 dez 87 + Forth definitions + +| : tcompile ( string -- ) dup find ?dup + IF 0> IF nip execute exit THEN THEN + drop gfind IF execute exit THEN number? ?dup + IF 0> IF swap T [compile] Literal THEN + [compile] Literal H exit THEN + symbolic execute ; + + Transient definitions + + : ] H ] ['] tcompile Is parser ; +( ----- 031 ) +\ Target conditionals ks 10 sep 86 + + : IF T compile ?branch >mark H 1 ; immediate restrict + : THEN abs 1 ?pairs T >resolve H ; immediate restrict + : ELSE 1 ?pairs T compile branch >mark + swap >resolve H -1 ; immediate restrict + + : BEGIN T mark H -2 2swap ; + immediate restrict + +| : (repeat 2 ?pairs T resolve H REPEAT ; + + : UNTIL T compile ?branch (repeat H ; immediate restrict + : REPEAT T compile branch (repeat H ; immediate restrict +( ----- 032 ) +\ Target conditionals Abort" etc. ks 09 feb 88 + + : DO T compile (do >mark H 3 ; immediate restrict + : ?DO T compile (?do >mark H 3 ; immediate restrict + : LOOP 3 ?pairs T compile (loop + compile endloop >resolve H ; immediate restrict + : +LOOP 3 ?pairs T compile (+loop + compile endloop >resolve H ; immediate restrict + + : Abort" T compile (abort" ," align H ; immediate restrict + : Error" T compile (error" ," align H ; immediate restrict +( ----- 033 ) +\ Target does> ;code ks 29 jun 87 + +| : dodoes> T compile (;code + H glast' @ there resdoes> there tdoes> ! ; + + : Does> H undefined? T dodoes> + $E9 c, H tdodo @ there - 2- T , + H ?reinterpret ; immediate restrict + + : ;Code H 0 ?pairs undefined? T dodoes> H ?reinterpret + T [compile] [ Assembler H ; immediate restrict +( ----- 034 ) +\ User ks 09 jul 87 + Forth definitions + + Variable torigin torigin off \ cold boot vector + Variable tudp tudp off \ user variable counter + : >user ( addr1 -- addr2 ) T c@ H torigin @ + ; + + Transient definitions Forth + + : origin! ( taddr -- ) H torigin ! tudp off ; + : uallot ( n -- offset ) H tudp @ swap tudp +! ; + + DO> >user ; + : User T prebuild User 2 uallot c, H ; +( ----- 035 ) +\ Variable Constant Create ks 01 okt 87 + + DO> ; + : Variable T prebuild Create 2 allot H ; + + DO> T @ H ; + : Constant T prebuild Constant , H ; + + DO> ; + : Create T prebuild Create H ; + + : Create: T Create ] H end-code 0 ; +( ----- 036 ) +\ Defer Is Vocabulary ks 29 jun 87 + + DO> ; + : Defer T prebuild Defer 2 allot ; + : Is T ' >body H state @ + IF T compile (is , H exit THEN T ! H ; immediate + + dummy + : Vocabulary H >in @ Vocabulary >in ! + T prebuild Vocabulary 0 , 0 , + H there tvoc-link @ T , H tvoc-link ! ; +( ----- 037 ) +\ File ks 19 m„r 88 + Forth definitions + + Variable tfile-link tfile-link off + Variable tfileno tfileno off + &45 Constant tb/fcb + + Transient definitions Forth + + dummy + : File T prebuild File here tb/fcb 0 fill + here H tfile-link @ T , H tfile-link ! + 1 tfileno +! tfileno @ T c, 0 , 0 , 0 , 0 , 0 , + here dup >r 1+ tb/fcb &13 - allot H tlast @ + T count dup r> c! + H bounds ?DO I T c@ over c! H 1+ LOOP drop ; +( ----- 038 ) +\ : ; compile Host [compile] ks 29 jun 87 + + dummy + : : H >in @ >in: ! T prebuild : ] H end-code 0 ; + + : ; 0 ?pairs T compile unnest + [compile] [ H ; immediate restrict + + : compile T compile compile H ; immediate restrict + + : Host H Onlyforth ; + + : Compiler H Onlyforth Transient also definitions ; + + : [compile] H ghost execute ; immediate restrict +( ----- 039 ) +\ Target ks 29 jun 87 + + Onlyforth + + : Target H vp off Transient also definitions ; + + Transient definitions + + ghost c, drop From baabc46391d2a2d0a28d8d21360dd3cdac4afab6 Mon Sep 17 00:00:00 2001 From: Carsten Strotmann Date: Sun, 11 Apr 2021 23:38:30 +0200 Subject: [PATCH 05/21] Stripped file and block words, english translation --- 8086/pc-baremetal/kernel.fth | 613 +++-------------------------------- 1 file changed, 38 insertions(+), 575 deletions(-) diff --git a/8086/pc-baremetal/kernel.fth b/8086/pc-baremetal/kernel.fth index f268664..0b5af21 100644 --- a/8086/pc-baremetal/kernel.fth +++ b/8086/pc-baremetal/kernel.fth @@ -12,44 +12,43 @@ Port to C16 "ultraFORTH" by C.Vogt Port to 8088/86 and MS-DOS by K.Schleisiek dez 87 ( ----- 001 ) \ MS-DOS volksForth Load Screen ks cas 18jul20 + warning off \ disable warnings during compilation Onlyforth \needs Transient include meta.fb - 2 loadfrom META.fb new FORTH.COM Onlyforth Target definitions 4 &111 thru \ Standard 8088-System - + warning on flush \ close FORTH.COM -cr .( new kernel as "FORTH.COM" written) cr bell bye +cr .( new kernel as "FORTH.COM" written) cr bell ( bye ) ( ----- 002 ) -\\ Die Nutzung der 8088/86 Register ks 27 oct 86 +\\ The use of the 8088/86 register ks 27 oct 86 -Im Assembler sind Forthgemaesse Namen fuer die Register gewaehlt -Dabei ist die Zuordnung zu den Intel Namen folgendermassen: +The assembler uses forth style names for the register +The assiciation to the Intel register names: A <=> AX A- <=> AL A+ <=> AH C <=> CX C- <=> CL C+ <=> CH - Register A und C sind zur allgemeinen Benutzung frei + Register A and C are available for general use D <=> DX D- <=> DL D+ <=> DH - das oberste Element des (Daten)-Stacks. + the Top of (Data-) Stack (TOS) R <=> BX R- <=> RL R+ <=> RH - der Return_stack_pointer + the Return_stack_pointer ( ----- 003 ) -\\ Die Nutzung der 8088/86 Register ks 27 oct 86 +\\ The use of the 8088/86 register ks 27 oct 86 U <=> BP User_area_pointer S <=> SP Daten_stack_pointer I <=> SI Instruction_pointer -W <=> DI Word_pointer, im allgemeinen zur Benutzung frei. +W <=> DI Word_pointer, free for general use D: <=> DS E: <=> ES S: <=> SS C: <=> CS - Alle Segmentregister werden beim booten auf den Wert des - Codesegments C: gesetzt und muessen, wenn sie "verstellt" - werden, wieder auf C: zurueckgesetzt werden. + All segment registers are set to the value of code-segment + C: and must be restored to the same if changed in the code ( ----- 004 ) \ FORTH Preamble and ID ks 11 m„r 89 Assembler @@ -58,12 +57,12 @@ nop 5555 # jmp here 2- >label >cold nop 5555 # jmp here 2- >label >restart Create origin here origin! here $100 0 fill -\ Hier beginnen die Kaltstartwerte der Benutzervariablen +\ Coldstart valued for user variables $E9 int end-code -4 , $FC allot \ this is the multitasker initialization in the user area -| Create logo ," volksFORTH-83 rev. 3.81.41" +| Create logo ," volksFORTH-83 Version 3.9.3" ( ----- 005 ) \ Next ks 27 oct 86 @@ -74,8 +73,8 @@ Create origin here origin! here $100 0 fill : Next lods A W xchg W ) jmp there tnext-link @ T , H tnext-link ! ; -\ Next ist in-line code. Fuer den debugger werden daher alle -\ "nexts" in einer Liste mit dem Anker NEXT-LINK verbunden. +\ Next is in-line code. All "nexts" are linked into a +\ list with the anchor NEXT-LINK for the debugger : u' ( -- offset ) T ' 2+ c@ H ; @@ -99,9 +98,9 @@ Target Code noop here 2- ! end-code ( ----- 007 ) \ User variables ks 16 sep 88 - 8 uallot drop \ Platz fuer Multitasker - \ Felder: entry link spare SPsave - \ Laenge kompatibel zum 68000, 6502 und 8080 volksFORTH + 8 uallot drop \ Space for the multitasker + \ Fields: entry link spare SPsave + \ Length compatible to 68000, 6502 and 8080 volksFORTH User s0 User r0 User dp @@ -112,7 +111,7 @@ Target User errorhandler \ pointer for Abort" -code User aborted \ code address of latest error User voc-link - User file-link cr .( Wieso ist UDP Uservariable? ) + User file-link ( TODO: Why is UDP a user variable? ) User udp \ points to next free addr in User_area ( ----- 008 ) \ manipulate system pointers ks 03 aug 87 @@ -723,7 +722,7 @@ Label domove I W cmp moveup CS ?] A- W ) mov W inc C0= ?] ]? Next end-code -\\ high level, ohne Umlaute +\\ high level definition, without umlauts : capital ( char -- char') dup Ascii a [ Ascii z 1+ ] Literal @@ -757,10 +756,9 @@ swap ]? C >in #) add ( ----- 054 ) \ source word parse name ks 03 aug 87 - Variable loadfile loadfile off - - : source ( -- addr len ) blk @ ?dup - IF loadfile @ (block b/blk exit THEN tib #tib @ exit ; + defer source + : (source ( -- addr len ) tib #tib @ exit ; + ' source Is (source : word ( char -- addr ) source (word ; @@ -911,10 +909,10 @@ swap ]? C >in #) add : | ?head @ ?exit ?head on ; + \ no alignment required on x86 : even ( addr -- addr1 ) ; immediate : align ( -- ) ; immediate : halign ( -- ) ; immediate -\ machen nichts beim 8088. 8086 koennte etwas schneller werden Variable warning warning on @@ -1154,7 +1152,7 @@ Target Forth also definitions \ : ?stack sp@ here - $100 u< IF stackfull THEN \ sp@ s0 @ u> Abort" stack empty" ; ( ----- 080 ) -\ .status push load ks 29 oct 86 +\ .status push ks 29 oct 86 | Create: pull r> r> ! ; : push ( addr -- ) @@ -1162,27 +1160,13 @@ Target Forth also definitions Defer .status ' noop Is .status - : (load ( blk offset -- ) isfile@ >r - loadfile @ >r fromfile @ >r blk @ >r >in @ >r - >in ! blk ! isfile@ loadfile ! .status interpret - r> >in ! r> blk ! r> fromfile ! r> loadfile ! - r> isfile ! ; - : load ( blk -- ) ?dup 0=exit 0 (load ; ( ----- 081 ) -\ +load thru +thru --> rdepth depth ks 26 jul 87 - - : +load ( offset -- ) blk @ + load ; - - : thru ( from to -- ) 1+ swap DO I load LOOP ; - - : +thru ( off0 off1 -- ) 1+ swap DO I +load LOOP ; - - : --> 1 blk +! >in off .status ; immediate : rdepth ( -- +n ) r0 @ rp@ 2+ - 2/ ; : depth ( -- +n ) sp@ s0 @ swap - 2/ ; + ( ----- 082 ) \ prompt quit ks 16 sep 88 @@ -1272,18 +1256,11 @@ Target Forth also definitions : .s sp@ s0 @ over - $20 umin bounds ?DO I @ u. 2 +LOOP ; ( ----- 088 ) -\ list c/l l/s ks 19 m„r 88 +\ c/l l/s ks 19 m„r 88 &64 Constant c/l \ Screen line length &16 Constant l/s \ lines per screen - : list ( scr -- ) dup capacity u< - IF scr ! ." Scr " scr @ . - ." Dr " drv . isfile@ .file - l/s 0 DO cr I 2 .r space scr @ block - I c/l * + c/l -trailing type - LOOP cr exit - THEN 9 ?diskerror ; ( ----- 089 ) \ multitasker primitives ks 29 oct 86 @@ -1302,140 +1279,28 @@ Target Forth also definitions end-code $E9 4 * >label >taskINT ( ----- 090 ) -\\ Struktur der Blockpuffer ks 04 jul 87 - 0 : link zum naechsten Puffer - 2 : file 0 = direct access - -1 = leer, - sonst adresse eines file control blocks - 4 : blocknummer - 6 : statusflags Vorzeichenbit kennzeichnet update - 8 : Data ... 1 Kb ... ( ----- 091 ) -\ buffer mechanism ks 04 okt 87 - - Variable isfile isfile off \ addr of file control block - Variable fromfile fromfile off \ fcb in kopieroperationen - - Variable prev prev off \ Listhead -| Variable buffers buffers off \ Semaphor - + $10000 Constant limit Variable first $408 Constant b/buf \ physikalische Groesse $400 Constant b/blk \ bytes/block Defer r/w \ physikalischer Diskzugriff - Variable error# error# off \ Nummer des letzten Fehlers - Defer ?diskerror \ Fehlerbehandlung + ( ----- 092 ) -\ (core? ks 28 mai 87 - Code (core? ( blk file -- dataaddr / blk file ) - A pop A push D D or 0= ?[ u' offset U D) A add ]? - prev #) W mov 2 W D) D cmp 0= - ?[ 4 W D) A cmp 0= - ?[ 8 W D) D lea A pop ' exit @ # jmp ]? ]? - [[ [[ W ) C mov C C or 0= ?[ Next ]? - C W xchg 4 W D) A cmp 0= ?] 2 W D) D cmp 0= ?] - W ) A mov prev #) D mov D W ) mov W prev #) mov - 8 W D) D lea C W mov A W ) mov A pop - ' exit @ # jmp - end-code ( ----- 093 ) -\\ (core? ks 31 oct 86 -| : this? ( blk file bufadr -- flag ) - dup 4+ @ swap 2+ @ d= ; - - .( (core?: offset is handled differently in code! ) - -| : (core? ( blk file -- dataaddr / blk file ) - BEGIN over offset @ + over prev @ this? - IF rdrop 2drop prev @ 8 + exit THEN - 2dup >r offset @ + >r prev @ - BEGIN dup @ ?dup 0= IF rdrop rdrop drop exit THEN - dup r> r> 2dup >r >r rot this? 0= - WHILE nip REPEAT - dup @ rot ! prev @ over ! prev ! rdrop rdrop - REPEAT ; ( ----- 094 ) -\ backup emptybuf readblk ks 23 jul 87 -| : backup ( bufaddr -- ) dup 6+ @ 0< - IF 2+ dup @ 1+ \ buffer empty if file = -1 - IF BEGIN dup 6+ over 2+ @ 2 pick @ 0 r/w - WHILE 1 ?diskerror REPEAT - THEN 4+ dup @ $7FFF and over ! THEN - drop ; - - : emptybuf ( bufaddr -- ) 2+ dup on 4+ off ; - -| : readblk ( blk file addr -- blk file addr ) - dup emptybuf >r - BEGIN 2dup 0= offset @ and + - over r@ 8 + -rot 1 r/w - WHILE 2 ?diskerror REPEAT r> ; ( ----- 095 ) -\ take mark updates? full? core? ks 04 jul 87 -| : take ( -- bufaddr) prev - BEGIN dup @ WHILE @ dup 2+ @ -1 = UNTIL - buffers lock dup backup ; - -| : mark ( blk file bufaddr -- blk file ) 2+ >r - 2dup r@ ! over 0= offset @ and + r@ 2+ ! - r> 4+ off buffers unlock ; - -| : updates? ( -- bufaddr / flag) - prev BEGIN @ dup WHILE dup 6+ @ 0< UNTIL ; - - : core? ( blk file -- addr /false ) (core? 2drop false ; ( ----- 096 ) -\ block & buffer manipulation ks 01 okt 87 - : (buffer ( blk file -- addr ) - BEGIN (core? take mark REPEAT ; - - : (block ( blk file -- addr ) - BEGIN (core? take readblk mark REPEAT ; - - Code isfile@ ( -- addr ) - D push isfile #) D mov Next end-code -\ : isfile@ ( -- addr ) isfile @ ; - - : buffer ( blk -- addr ) isfile@ (buffer ; - - : block ( blk -- addr ) isfile@ (block ; ( ----- 097 ) -\ block & buffer manipulation ks 02 okt 87 - : update $80 prev @ 6+ 1+ ( Byte-Order! ) c! ; - - : save-buffers buffers lock - BEGIN updates? ?dup WHILE backup REPEAT buffers unlock ; - - : empty-buffers buffers lock prev - BEGIN @ ?dup WHILE dup emptybuf REPEAT buffers unlock ; - - : flush file-link - BEGIN @ ?dup WHILE dup fclose REPEAT - save-buffers empty-buffers ; ( ----- 098 ) -\ Allocating buffers ks 31 oct 86 - $10000 Constant limit Variable first - : allotbuffer ( -- ) - first @ r0 @ - b/buf 2+ u< ?exit - b/buf negate first +! first @ dup emptybuf - prev @ over ! prev ! ; - - : freebuffer ( -- ) first @ limit b/buf - u< - IF first @ backup prev - BEGIN dup @ first @ - WHILE @ REPEAT - first @ @ swap ! b/buf first +! THEN ; - - : all-buffers BEGIN first @ allotbuffer first @ = UNTIL ; - -| : init-buffers prev off limit first ! all-buffers ; ( ----- 099 ) \ endpoints of forget uh 27 apr 88 @@ -1483,7 +1348,7 @@ Target Forth also definitions Defer custom-remove ' noop Is custom-remove : trim ( dic symb -- ) next-link remove - over remove-tasks remove-vocs remove-words remove-files + over remove-tasks remove-vocs remove-words custom-remove heap swap - hallot dp ! last off ; ( ----- 102 ) \ deleting words from dict. ks 02 okt 87 @@ -1557,7 +1422,7 @@ Target Forth also definitions | : (cold origin up@ $100 cmove $80 count $50 umin >r tib r@ move r> #tib ! >in off blk off - init-vocabularys init-buffers flush 'cold + init-vocabularys 'cold Onlyforth page &24 spaces logo count type cr (restart ; ( ----- 107 ) \ (boot ks 11 m„r 89 @@ -1599,7 +1464,7 @@ Target Forth also definitions $21 int warmboot # call end-code - : bye flush empty page (bye ; + : bye empty page (bye ; ( ----- 110 ) \ cold ks 09 m„r 89 @@ -1616,7 +1481,7 @@ Target Forth also definitions ( ----- 111 ) \ System patchup ks 16 sep 88 - 1 &35 +thru \ MS-DOS interface + 1 &9 +thru \ MS-DOS interface : forth-83 ; \ last word in Dictionary @@ -1660,10 +1525,10 @@ Target Forth also definitions A D: mov D pop Next end-code ( ----- 114 ) \ BDOS keyboard input ks 16 sep 88 -\ es muss wirklich so kompliziert sein, da sonst kein ^C und ^P +\ it really needs to be this complicated, else ^C und ^P would +\ not work \\ | Variable newkey newkey off - Code (key@ ( -- 8b ) D push newkey #) D mov D+ D+ or 0= ?[ $7 # A+ mov $21 int A- D- mov ]? 0 # D+ mov D+ newkey 1+ #) mov Next @@ -1739,407 +1604,5 @@ Target Forth also definitions Output: display [ here output ! ] (emit (cr tipp (del (page (at (at? [ drop + ( ----- 120 ) -\ MSDOS printer I/O Port access ks 09 aug 87 - - Code lst! ( 8b -- ) $5 # A+ mov $21 int D pop Next - end-code - - Code pc@ ( port -- 8b ) - D byte in A- D- mov D+ D+ xor Next - end-code - - Code pc! ( 8b port -- ) - A pop D byte out D pop Next - end-code -( ----- 121 ) -\ zero terminated strings ks 09 aug 87 - - : counted ( asciz -- addr len ) - dup -1 0 scan drop over - ; - - : >asciz ( string addr -- asciz ) 2dup >r - - IF count r@ place r@ THEN 0 r> count + c! 1+ ; - - - - : asciz ( -- asciz ) name here >asciz ; -( ----- 122 ) -\ Disk capacities ks 08 aug 88 - Vocabulary Dos Dos also definitions - - 6 Constant #drives - - Create capacities $4B0 , $4B0 , $1B31 , $1B31 , $1B0F , 0 , - -| Code ?capacity ( +n -- cap ) D shl capacities # W mov - D W add W ) D mov Next end-code -( ----- 123 ) -\ MS-dos disk handlers direct access ks 31 jul 87 - -| Code block@ ( addr blk drv -- ff ) - D- A- mov D pop C pop R push U push - I push C R mov 2 # C mov D shl $25 int - Label end-r/w I pop I pop U pop R pop 0 # D mov - CS ?[ D+ A+ mov A error# #) mov D dec ]? Next - end-code - -| Code block! ( addr blk drv -- ff ) D- A- mov D pop - C pop R push U push I push C R mov 2 # C mov - D shl $26 int end-r/w # jmp - end-code -( ----- 124 ) -\ MS-dos disk handlers direct access ks cas 18jul20 - -| : ?drive ( +n -- +n ) dup #drives u< ?exit - Error" beyond drive capacity" ; - - : /drive ( blk1 -- blk2 drive ) 0 swap #drives 0 - DO dup I ?capacity under u< IF drop LEAVE THEN - - swap 1+ swap LOOP swap ; - - : blk/drv ( -- capacity ) drv ?capacity ; - - Forth definitions - - : >drive ( blk1 +n -- blk2 ) ?drive - 0 swap drv 2dup u> dup >r 0= IF swap THEN - ?DO I ?capacity + LOOP r> IF negate THEN - ; -( ----- 125 ) -\ MS-DOS file access ks 18 m„r 88 - Dos definitions - -| Variable fcb fcb off \ last fcb accessed -| Variable prevfile \ previous active file - - &30 Constant fnamelen \ default length in FCB - - Create filename &62 allot \ max 60 + count + null - - Variable attribut 7 attribut ! \ read-only, hidden, system -( ----- 126 ) -\ MS-DOS disk errors ks cas 18jul20 - -| : .error# ." error # " base push decimal error# @ . ; - -| : .ferrors error# @ &18 case? IF 2 THEN - 1 case? Abort" file exists" - 2 case? Abort" file not found" - 3 case? Abort" path not found" - 4 case? Abort" too many open files" - 5 case? Abort" no access" - 9 case? Abort" beyond end of file" - &15 case? Abort" illegal drive" - &16 case? Abort" current directory" - &17 case? Abort" wrong drive" - drop ." Disk" .error# abort ; -( ----- 127 ) -\ MS-DOS disk errors ks cas 18jul20 - - : (diskerror ( *f -- ) ?dup 0=exit - fcb @ IF error# ! .ferrors exit THEN - input push output push standardi/o 1- - IF ." read" ELSE ." write" THEN - .error# ." retry? (y/n)" - key cr capital Ascii Y = not Abort" aborted" ; - - ' (diskerror Is ?diskerror -( ----- 128 ) -\ ~open ~creat ~close ks 04 aug 87 - - Code ~open ( asciz mode -- handle ff / err# ) - A D xchg $3D # A+ mov - Label >open D pop $21 int A D xchg - CS not ?[ D push 0 # D mov ]? Next - end-code - - Code ~creat ( asciz attribut -- handle ff / err# ) - D C mov $3C # A+ mov >open ]] end-code - - Code ~close ( handle -- ) D R xchg - $3E # A+ mov $21 int R D xchg D pop Next - end-code -( ----- 129 ) -\ ~first ~unlink ~select ~disk? ks 04 aug 87 - - Code ~first ( asciz attr -- err# ) - D C mov D pop $4E # A+ mov - [[ $21 int 0 # D mov CS ?[ A D xchg ]? Next - end-code - - Code ~unlink ( asciz -- err# ) $41 # A+ mov ]] end-code - - Code ~select ( n -- ) - $E # A+ mov $21 int D pop Next end-code - - Code ~disk? ( -- n ) D push $19 # A+ mov - $21 int A- D- mov 0 # D+ mov Next - end-code -( ----- 130 ) -\ ~next ~dir ks 04 aug 87 - - Code ~next ( -- err# ) D push $4F # A+ mov - $21 int 0 # D mov CS ?[ A D xchg ]? Next - end-code - - Code ~dir ( addr drive -- err# ) I W mov - I pop $47 # A+ mov $21 int W I mov - 0 # D mov CS ?[ A D xchg ]? Next - end-code -( ----- 131 ) -\ MS-DOS file control Block cas 19jun20 - -| : Fcbytes ( n1 len -- n2 ) Create over c, + - Does> ( fcbaddr -- fcbfield ) c@ + ; - -\ first field for file-link -2 1 Fcbytes f.no \ must be first field - 2 Fcbytes f.handle - 2 Fcbytes f.date - 2 Fcbytes f.time - 4 Fcbytes f.size - fnamelen Fcbytes f.name Constant b/fcb - -b/fcb Host ' tb/fcb >body ! - Target Forth also Dos also definitions -( ----- 132 ) -\ (.file fname fname! ks 10 okt 87 - - : fname! ( string fcb -- ) f.name >r count - dup fnamelen < not Abort" file name too long" r> place ; - -| : filebuffer? ( fcb -- fcb bufaddr / fcb ff ) - prev BEGIN @ dup WHILE 2dup 2+ @ = UNTIL ; - -| : flushfile ( fcb -- ) - BEGIN filebuffer? ?dup - WHILE dup backup emptybuf REPEAT drop ; - - : fclose ( fcb -- ) ?dup 0=exit - dup f.handle @ ?dup 0= IF drop exit THEN - over flushfile ~close f.handle off ; -( ----- 133 ) -\ (.file fname fname! ks 18 m„r 88 - -| : getsize ( -- d ) [ $80 &26 + ] Literal 2@ swap ; - - : (fsearch ( string -- asciz *f ) - filename >asciz dup attribut @ ~first ; - - Defer fsearch ( string -- asciz *f ) - - ' (fsearch Is fsearch - -\ graceful behaviour if file does not exist -| : ?notfound ( f* -- ) ?dup 0=exit last' @ [fcb] = - IF hide file-link @ @ file-link ! prevfile @ setfiles - last @ 4 - dp ! last off filename count here place - THEN ?diskerror ; -( ----- 134 ) -\ freset fseek ks 19 m„r 88 - - : freset ( fcb -- ) ?dup 0=exit - dup f.handle @ ?dup IF ~close THEN dup >r - f.name fsearch ?notfound getsize r@ f.size 2! - [ $80 &22 + ] Literal @ r@ f.time ! - [ $80 &24 + ] Literal @ r@ f.date ! - 2 ~open ?diskerror r> f.handle ! ; - - - Code fseek ( dfaddr fcb -- ) - D W mov u' f.handle W D) W mov W W or 0= - ?[ ;c: dup freset fseek ; Assembler ]? R W xchg - C pop D pop $4200 # A mov $21 int W R mov - CS not ?[ D pop Next ]? A D xchg ;c: ?diskerror ; -( ----- 135 ) -\ lfgets fgetc file@ ks 07 jul 88 - -\ Code ~read ( seg:addr quan handle -- #read ) D W mov -Assembler [[ W R xchg C pop D pop - D: pop $3F # A+ mov $21 int C: C mov C D: mov - W R mov A D xchg CS not ?[ Next ]? ;c: ?diskerror ; - - Code lfgets ( seg:addr quan fcb -- #read ) - D W mov u' f.handle W D) W mov ]] end-code - - true Constant eof - - : fgetc ( fcb -- 8b / eof ) - >r 0 sp@ ds@ swap 1 r> lfgets ?exit 0= ; - - : file@ ( dfaddr fcb -- 8b / eof ) dup >r fseek r> fgetc ; -( ----- 136 ) -\ lfputs fputc file! ks 24 jul 87 - -| Code ~write ( seg:addr quan handle -- ) D W mov -[[ W R xchg C pop D pop - D: pop $40 # A+ mov $21 int W R mov A D xchg - C: W mov W D: mov CS ?[ ;c: ?diskerror ; Assembler ]? - C D sub 0= ?[ D pop Next ]? ;c: Abort" Disk voll" ; - - Code lfputs ( seg:addr quan fcb -- ) - D W mov u' f.handle W D) W mov ]] end-code - - : fputc ( 8b fcb -- ) >r sp@ ds@ swap 1 r> lfputs drop ; - - : file! ( 8b dfaddr fcb -- ) dup >r fseek r> fputc ; -( ----- 137 ) -\ /block *block ks 02 okt 87 - - Code /block ( d -- rest blk ) A D xchg C pop - C D mov A shr D rcr A shr D rcr D+ D- mov - A- D+ xchg $3FF # C and C push Next - end-code -\ : /block ( d -- rest blk ) b/blk um/mod ; - - Code *block ( blk -- d ) A A xor D+ D- xchg D+ A+ xchg - A+ sal D rcl A+ sal D rcl A push Next - end-code -\ : *block ( blk -- d ) b/blk um* ; -( ----- 138 ) -\ fblock@ fblock! ks 19 m„r 88 - Dos definitions - -| : ?beyond ( blk -- blk ) dup 0< 0=exit 9 ?diskerror ; - -| : fblock ( addr blk fcb -- seg:addr quan fcb ) - fcb ! ?beyond dup *block fcb @ fseek ds@ -rot - fcb @ f.size 2@ /block rot - ?beyond - IF drop b/blk THEN fcb @ ; - - : fblock@ ( addr blk fcb -- ) fblock lfgets drop ; - - : fblock! ( addr blk fcb -- ) fblock lfputs ; -( ----- 139 ) -\ (r/w flush ks 18 m„r 88 - Forth definitions - - : (r/w ( addr blk fcb r/wf -- *f ) over fcb ! over - IF IF fblock@ false exit THEN fblock! false exit - THEN >r drop /drive ?drive - r> IF block@ exit THEN block! ; - - ' (r/w Is r/w - -| : setfiles ( fcb -- ) isfile@ prevfile ! - dup isfile ! fromfile ! ; - - : direct 0 setfiles ; -( ----- 140 ) -\ File >file ks 23 m„r 88 - - : File Create file-link @ here file-link ! , - here [ b/fcb 2 - ] Literal dup allot erase - file-link @ dup @ f.no c@ 1+ over f.no c! - last @ count $1F and rot f.name place - Does> setfiles ; - - File kernel.scr ' kernel.scr @ Constant [fcb] - - Dos definitions - - : .file ( fcb -- ) - ?dup IF body> >name .name exit THEN ." direct" ; -( ----- 141 ) -\ .file pushfile close open ks 12 mai 88 - Forth definitions - - : file? isfile@ .file ; - - : pushfile r> isfile push fromfile push >r ; restrict - - : close isfile@ fclose ; - - : open isfile@ freset ; - - : assign isfile@ dup fclose name swap fname! open ; -( ----- 142 ) -\ use from loadfrom include ks 18 m„r 88 - - : use >in @ name find - 0= IF swap >in ! File last' THEN nip - dup @ [fcb] = over ['] direct = or - 0= Abort" not a file" execute open ; - - : from isfile push use ; - - : loadfrom ( n -- ) pushfile use load close ; - - : include 1 loadfrom ; -( ----- 143 ) -\ drive drv capacity drivenames ks 18 m„r 88 - - : drive ( n -- ) isfile@ IF ~select exit THEN - ?drive offset off 0 ?DO I ?capacity offset +! LOOP ; - - : drv ( -- n ) - isfile@ IF ~disk? exit THEN offset @ /drive nip ; - - : capacity ( -- n ) isfile@ ?dup - IF dup f.handle @ 0= IF dup freset THEN - f.size 2@ /block swap 0<> - exit THEN blk/drv ; - -| : Drv: Create c, Does> c@ drive ; - - 0 Drv: A: 1 Drv: B: 2 Drv: C: 3 Drv: D: - 4 Drv: E: 5 Drv: F: 6 Drv: G: 7 Drv: H: -( ----- 144 ) -\ lfsave savefile savesystem ks 10 okt 87 - - : lfsave ( seg:addr quan string -- ) - filename >asciz 0 ~creat ?diskerror - dup >r ~write r> ~close ; - - : savefile ( addr len -- ) ds@ -rot - name nullstring? Abort" needs name" lfsave ; - - : savesystem save flush $100 here savefile ; -( ----- 145 ) -\ viewing ks 19 m„r 88 - Dos definitions -| $400 Constant viewoffset - - : (makeview ( -- n ) - blk @ dup 0=exit loadfile @ ?dup 0=exit f.no c@ ?dup - IF viewoffset * + $8000 or exit THEN 0= ; - ' (makeview Is makeview - - : @view ( acf -- blk fno ) >name 4 - @ dup 0< - IF $7FFF and viewoffset u/mod exit THEN - ?dup 0= Error" eingetippt" 0 ; - - : >file ( fno -- fcb ) dup 0=exit file-link - BEGIN @ dup WHILE 2dup f.no c@ = UNTIL nip ; -( ----- 146 ) -\ forget FCB's ks 23 okt 88 - Forth definitions -| : 'file ( -- scr ) r> scr push isfile push >r - [ Dos ] ' @view >file isfile ! ; - - : view 'file list ; - : help 'file capacity 2/ + list ; - -| : remove? ( dic symb addr -- dic symb addr f ) - 2 pick over 1+ u< ; - -| : remove-files ( dic symb -- dic symb ) file-link - BEGIN @ ?dup WHILE remove? IF dup fclose THEN REPEAT - file-link remove - isfile@ remove? nip IF file-link @ isfile ! THEN - fromfile @ remove? nip 0=exit isfile@ fromfile ! ; -( ----- 147 ) -\ BIOS keyboard input ks 16 sep 88 - - Code (key@ ( -- 8b ) D push A+ A+ xor $16 int - 0 # D+ mov A- D- mov A- A- or - 0= ?[ A+ D- mov D+ com ]? Next end-code - - : test BEGIN (key@ #esc case? ?exit - cr dup emit 5 .r key 5 .r REPEAT ; -\\ - Code (key? ( -- f ) D push 1 # A+ mov D D xor - $16 int 0= not ?[ D dec ]? Next end-code - - Code empty-keys $C00 # A mov $21 int Next end-code - - : (key ( -- 8b ) BEGIN pause (key? UNTIL (key@ ; From 6a3c1a30acfefec29bd030bd85b70d165cf02ff6 Mon Sep 17 00:00:00 2001 From: Carsten Strotmann Date: Mon, 12 Apr 2021 14:36:28 +0200 Subject: [PATCH 06/21] Fix in source --- 8086/pc-baremetal/kernel.fth | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/8086/pc-baremetal/kernel.fth b/8086/pc-baremetal/kernel.fth index 0b5af21..8884fb7 100644 --- a/8086/pc-baremetal/kernel.fth +++ b/8086/pc-baremetal/kernel.fth @@ -22,7 +22,7 @@ Port to 8088/86 and MS-DOS by K.Schleisiek dez 87 warning on flush \ close FORTH.COM -cr .( new kernel as "FORTH.COM" written) cr bell ( bye ) +cr .( new kernel as "FORTH.COM" written) cr bell bye ( ----- 002 ) \\ The use of the 8088/86 register ks 27 oct 86 @@ -757,7 +757,7 @@ swap ]? C >in #) add \ source word parse name ks 03 aug 87 defer source - : (source ( -- addr len ) tib #tib @ exit ; + : (source ( -- addr len ) tib #tib @ ; ' source Is (source : word ( char -- addr ) source (word ; @@ -1482,7 +1482,6 @@ Target Forth also definitions \ System patchup ks 16 sep 88 1 &9 +thru \ MS-DOS interface - : forth-83 ; \ last word in Dictionary 0 ' limit >body ! $DFF6 s0 ! $E77C r0 ! @@ -1527,7 +1526,7 @@ Target Forth also definitions \ BDOS keyboard input ks 16 sep 88 \ it really needs to be this complicated, else ^C und ^P would \ not work -\\ + | Variable newkey newkey off Code (key@ ( -- 8b ) D push newkey #) D mov D+ D+ or 0= ?[ $7 # A+ mov $21 int A- D- mov ]? @@ -1542,7 +1541,7 @@ Target Forth also definitions end-code ( ----- 115 ) \ empty-keys (key ks 16 sep 88 -\\ + Code empty-keys $C00 # A mov $21 int 0 # newkey 1+ #) byte mov Next end-code @@ -1550,7 +1549,7 @@ Target Forth also definitions (key@ ?dup ?exit (key? IF (key@ negate exit THEN 0 ; ( ----- 116 ) \ BIOS keyboard input ks 16 sep 88 - +\\ Code (key@ ( -- 8b ) D push A+ A+ xor $16 int A- D- xchg 0 # D+ mov Next end-code From 269f9a83e20e95bfeefeb1d4078700b118e06da2 Mon Sep 17 00:00:00 2001 From: Carsten Strotmann Date: Mon, 12 Apr 2021 15:15:18 +0200 Subject: [PATCH 07/21] Translation and small fix in "source" --- 8086/pc-baremetal/Makefile | 2 +- 8086/pc-baremetal/kernel.fth | 28 ++++++++++++++-------------- 2 files changed, 15 insertions(+), 15 deletions(-) diff --git a/8086/pc-baremetal/Makefile b/8086/pc-baremetal/Makefile index f2931ce..95f43ae 100644 --- a/8086/pc-baremetal/Makefile +++ b/8086/pc-baremetal/Makefile @@ -9,7 +9,7 @@ all: $(TARGET) $(BLKPACK) < $< > $@ $(TARGET): kernel.fb meta.fb - emu2 $(BASE)/8086/msdos/volks4th.com "include kernel.fb" + emu2 $(BASE)/8086/msdos/volks4th.com "include kernel.fb bye" .PHONY: clean clean: diff --git a/8086/pc-baremetal/kernel.fth b/8086/pc-baremetal/kernel.fth index 8884fb7..399e914 100644 --- a/8086/pc-baremetal/kernel.fth +++ b/8086/pc-baremetal/kernel.fth @@ -22,7 +22,7 @@ Port to 8088/86 and MS-DOS by K.Schleisiek dez 87 warning on flush \ close FORTH.COM -cr .( new kernel as "FORTH.COM" written) cr bell bye +cr .( new kernel as "FORTH.COM" written) cr bell ( ----- 002 ) \\ The use of the 8088/86 register ks 27 oct 86 @@ -667,7 +667,7 @@ Label domove I W cmp moveup CS ?] : tib ( -- addr ) >tib @ ; - : query tib $50 expect span @ #tib ! >in off ; + : query tib $50 expect span @ #tib ! >in off ; ( ----- 048 ) \ skip scan /string ks 22 dez 87 @@ -758,7 +758,7 @@ swap ]? C >in #) add defer source : (source ( -- addr len ) tib #tib @ ; - ' source Is (source + ' (source Is source : word ( char -- addr ) source (word ; @@ -1169,7 +1169,6 @@ Target Forth also definitions ( ----- 082 ) \ prompt quit ks 16 sep 88 - : (prompt .status state @ IF cr ." ] " exit THEN aborted @ 0= IF ." ok" THEN cr ; @@ -1179,7 +1178,7 @@ Target Forth also definitions Defer 'quit ' (quit Is 'quit - : quit r0 @ rp! [compile] [ blk off 'quit ; + : quit r0 @ rp! [compile] [ blk off 'quit ; \ : classical cr .status state @ \ IF ." C> " exit THEN ." I> " ; @@ -1256,7 +1255,7 @@ Target Forth also definitions : .s sp@ s0 @ over - $20 umin bounds ?DO I @ u. 2 +LOOP ; ( ----- 088 ) -\ c/l l/s ks 19 m„r 88 +\ c/l l/s &64 Constant c/l \ Screen line length &16 Constant l/s \ lines per screen @@ -1282,10 +1281,10 @@ Target Forth also definitions ( ----- 091 ) $10000 Constant limit Variable first - $408 Constant b/buf \ physikalische Groesse + $408 Constant b/buf \ real size of block buffer $400 Constant b/blk \ bytes/block - Defer r/w \ physikalischer Diskzugriff + Defer r/w \ low level disk access word ( ----- 092 ) @@ -1481,7 +1480,7 @@ Target Forth also definitions ( ----- 111 ) \ System patchup ks 16 sep 88 - 1 &9 +thru \ MS-DOS interface + 1 &10 +thru \ MS-DOS interface : forth-83 ; \ last word in Dictionary 0 ' limit >body ! $DFF6 s0 ! $E77C r0 ! @@ -1526,7 +1525,7 @@ Target Forth also definitions \ BDOS keyboard input ks 16 sep 88 \ it really needs to be this complicated, else ^C und ^P would \ not work - +\\ | Variable newkey newkey off Code (key@ ( -- 8b ) D push newkey #) D mov D+ D+ or 0= ?[ $7 # A+ mov $21 int A- D- mov ]? @@ -1541,7 +1540,7 @@ Target Forth also definitions end-code ( ----- 115 ) \ empty-keys (key ks 16 sep 88 - +\\ Code empty-keys $C00 # A mov $21 int 0 # newkey 1+ #) byte mov Next end-code @@ -1549,7 +1548,7 @@ Target Forth also definitions (key@ ?dup ?exit (key? IF (key@ negate exit THEN 0 ; ( ----- 116 ) \ BIOS keyboard input ks 16 sep 88 -\\ + Code (key@ ( -- 8b ) D push A+ A+ xor $16 int A- D- xchg 0 # D+ mov Next end-code @@ -1560,8 +1559,8 @@ Target Forth also definitions : (key ( -- 8b ) BEGIN pause (key? UNTIL (key@ ; -\ mit diesen Keytreibern sind die Funktionstasten nicht -\ mehr durch ANSI.SYS Sequenzen vorbelegt. +\ when this kernel driver are active the function keys +\ cannot be used for ANSI.SYS makros ( ----- 117 ) \ (decode expect ks 16 sep 88 @@ -1605,3 +1604,4 @@ Target Forth also definitions (emit (cr tipp (del (page (at (at? [ drop ( ----- 120 ) + From dc865fdd5ece45b677c89be7c85d8bc3c04ba680 Mon Sep 17 00:00:00 2001 From: Carsten Strotmann Date: Mon, 12 Apr 2021 19:44:38 +0200 Subject: [PATCH 08/21] Working Bare-Metal Kernel --- 8086/pc-baremetal/kernel.fth | 112 ++++++++++++++++------------------- 1 file changed, 52 insertions(+), 60 deletions(-) diff --git a/8086/pc-baremetal/kernel.fth b/8086/pc-baremetal/kernel.fth index 399e914..bbebb33 100644 --- a/8086/pc-baremetal/kernel.fth +++ b/8086/pc-baremetal/kernel.fth @@ -1,15 +1,13 @@ ( ----- 000 ) -\ #### volksFORTH #### cas 18jul20 -VolksForth has been developed by +\ #### volksFORTH #### cas 11apr21 + volksFORTH designed and developed by + the volksFORTH team - K. Schleisiek, B. Pennemann, G. Rehfeld, D. Weineck - Ulli Hoffmann, Philip Zembrod, Carsten Strotmann -6502 version by B.Pennemann and K.Schleisiek -Port to C64 "ultraFORTH" by G. Rehfeld -Port to 68000 and Atari ST by D.Weineck and B.Pennemann -Port to 8080 and CP/M by U.Hoffmann jul 86 -Port to C16 "ultraFORTH" by C.Vogt -Port to 8088/86 and MS-DOS by K.Schleisiek dez 87 + see https://volksforth.sf.net + https://github.com/forth-ev/VolksForth + + for documentation, updated versions and development + information ( ----- 001 ) \ MS-DOS volksForth Load Screen ks cas 18jul20 warning off \ disable warnings during compilation @@ -27,11 +25,11 @@ cr .( new kernel as "FORTH.COM" written) cr bell \\ The use of the 8088/86 register ks 27 oct 86 The assembler uses forth style names for the register -The assiciation to the Intel register names: +Mapping of Forth Registernames to INTEL Register Names: A <=> AX A- <=> AL A+ <=> AH C <=> CX C- <=> CL C+ <=> CH - Register A and C are available for general use + Register A and C are free to use D <=> DX D- <=> DL D+ <=> DH the Top of (Data-) Stack (TOS) @@ -57,7 +55,7 @@ nop 5555 # jmp here 2- >label >cold nop 5555 # jmp here 2- >label >restart Create origin here origin! here $100 0 fill -\ Coldstart valued for user variables +\ Coldstart values for user variables $E9 int end-code -4 , $FC allot \ this is the multitasker initialization in the user area @@ -667,7 +665,7 @@ Label domove I W cmp moveup CS ?] : tib ( -- addr ) >tib @ ; - : query tib $50 expect span @ #tib ! >in off ; + : query tib $50 expect span @ #tib ! >in off ; ( ----- 048 ) \ skip scan /string ks 22 dez 87 @@ -1178,10 +1176,10 @@ Target Forth also definitions Defer 'quit ' (quit Is 'quit - : quit r0 @ rp! [compile] [ blk off 'quit ; + : quit r0 @ rp! [compile] [ blk off + key? IF key drop THEN + 'quit ; -\ : classical cr .status state @ -\ IF ." C> " exit THEN ." I> " ; ( ----- 083 ) \ end-trace abort ks 26 jul 87 @@ -1347,7 +1345,7 @@ Target Forth also definitions Defer custom-remove ' noop Is custom-remove : trim ( dic symb -- ) next-link remove - over remove-tasks remove-vocs remove-words + over remove-tasks remove-vocs remove-words custom-remove heap swap - hallot dp ! last off ; ( ----- 102 ) \ deleting words from dict. ks 02 okt 87 @@ -1363,7 +1361,7 @@ Target Forth also definitions : empty [ dp ] Literal @ up@ trim [ udp ] Literal @ udp ! ; ( ----- 103 ) -\ save bye stop? ?cr ks 1UH 26sep88 +\ save stop? ?cr ks 1UH 26sep88 : save here up@ trim up@ origin $100 cmove voc-link @ BEGIN dup 4- @ over 2- ! @ ?dup 0= UNTIL ; @@ -1421,8 +1419,8 @@ Target Forth also definitions | : (cold origin up@ $100 cmove $80 count $50 umin >r tib r@ move r> #tib ! >in off blk off - init-vocabularys 'cold - Onlyforth page &24 spaces logo count type cr (restart ; + init-vocabularys 'cold Onlyforth $80 c@ 0= IF + page logo count type cr THEN (restart ; ( ----- 107 ) \ (boot ks 11 m„r 89 @@ -1459,8 +1457,8 @@ Target Forth also definitions | Code (bye cli A A xor A E: mov #segs # call C: D mov D R add R D: mov 0 # I mov I W mov $200 # C mov rep movs sti \ restore interrupts - $4C # A+ mov C: seg return_code #) A- mov - $21 int warmboot # call + \ $4C # A+ mov C: seg return_code #) A- mov $21 int + warmboot # call end-code : bye empty page (bye ; @@ -1469,9 +1467,9 @@ Target Forth also definitions here >cold 2+ - >cold ! Assembler (boot # call C: A mov A D: mov A E: mov - #segs # call $41 # R add \ another k for the ints - $4A # A+ mov $21 int \ alloc memory - CS ?[ $10 # return_code #) byte mov ' (bye @ # jmp ]? + \ #segs # call $41 # R add \ another k for the ints + \ $4A # A+ mov $21 int \ alloc memory + \ CS ?[ $10 # return_code #) byte mov ' (bye @ # jmp ]? here s0 #) W mov 6 # W add origin # I mov $20 # C mov rep movs ' (cold >body # I mov bootsystem # jmp end-code @@ -1480,7 +1478,7 @@ Target Forth also definitions ( ----- 111 ) \ System patchup ks 16 sep 88 - 1 &10 +thru \ MS-DOS interface + 1 &11 +thru \ PC-BIOS interface : forth-83 ; \ last word in Dictionary 0 ' limit >body ! $DFF6 s0 ! $E77C r0 ! @@ -1522,30 +1520,9 @@ Target Forth also definitions ]? A I xchg C: A mov A E: mov A D: mov D pop Next end-code ( ----- 114 ) -\ BDOS keyboard input ks 16 sep 88 -\ it really needs to be this complicated, else ^C und ^P would -\ not work -\\ -| Variable newkey newkey off - Code (key@ ( -- 8b ) D push newkey #) D mov D+ D+ or - 0= ?[ $7 # A+ mov $21 int A- D- mov ]? - 0 # D+ mov D+ newkey 1+ #) mov Next - end-code - Code (key? ( -- f ) D push newkey #) D mov D+ D+ or - 0= ?[ -1 # D- mov 6 # A+ mov $21 int 0= - ?[ 0 # D+ mov - ][ -1 # A+ mov A newkey #) mov -1 # D+ mov - ]? ]? D+ D- mov Next - end-code ( ----- 115 ) -\ empty-keys (key ks 16 sep 88 -\\ - Code empty-keys $C00 # A mov $21 int - 0 # newkey 1+ #) byte mov Next end-code - : (key ( -- 16b ) BEGIN pause (key? UNTIL - (key@ ?dup ?exit (key? IF (key@ negate exit THEN 0 ; ( ----- 116 ) \ BIOS keyboard input ks 16 sep 88 @@ -1555,22 +1532,20 @@ Target Forth also definitions Code (key? ( -- f ) D push 1 # A+ mov D D xor $16 int 0= not ?[ D dec ]? Next end-code - Code empty-keys $C00 # A mov $21 int Next end-code + : empty-keys ; : (key ( -- 8b ) BEGIN pause (key? UNTIL (key@ ; -\ when this kernel driver are active the function keys -\ cannot be used for ANSI.SYS makros ( ----- 117 ) \ (decode expect ks 16 sep 88 - 7 Constant #bel 8 Constant #bs 9 Constant #tab $A Constant #lf - $D Constant #cr - + $D Constant #cr $26 Constant #eof : (decode ( addr pos1 key -- addr pos2 ) - #bs case? IF dup 0=exit del 1- exit THEN - #cr case? IF dup span ! space exit THEN + #bs case? IF dup 0=exit del 1- exit THEN + #cr case? IF dup span ! space exit THEN + #lf case? IF exit THEN + #eof case? IF bye THEN >r 2dup + r@ swap c! r> emit 1+ ; : (expect ( addr len1 -- ) span ! 0 @@ -1579,10 +1554,10 @@ Target Forth also definitions Input: keyboard [ here input ! ] (key (key? (decode (expect [ drop ( ----- 118 ) -\ MSDOS character output ks 29 jun 87 +\ BIOS character output ks 29 jun 87 - Code charout ( char -- ) $FF # D- cmp 0= ?[ D- dec ]? - 6 # A+ mov $21 int D pop ' pause # W mov W ) jmp + Code charout ( char -- ) D- A- mov + $E # A+ mov $10 int D pop ' pause # W mov W ) jmp end-code &80 Constant c/row &25 Constant c/col @@ -1594,7 +1569,7 @@ Target Forth also definitions : (at? 0 0 ; : (page c/col 0 DO cr LOOP ; ( ----- 119 ) -\ MSDOS character output ks 7 may 85 +\ BIOS character output ks 7 may 85 : bell #bel charout ; @@ -1605,3 +1580,20 @@ Target Forth also definitions ( ----- 120 ) + Code pc@ ( port -- 8b ) + D byte in A- D- mov D+ D+ xor Next + end-code + + Code pc! ( 8b port -- ) + A pop D byte out D pop Next + end-code +( ----- 121 ) +\ zero terminated strings cas 25jan06 + + : counted ( asciz -- addr len ) + dup -1 0 scan drop over - ; + + : >asciz ( string addr -- asciz ) 2dup >r - + IF count r@ place r@ THEN 0 r> count + c! 1+ ; + + : asciz ( -- asciz ) name here >asciz ; From 2ca3cf3519133bb0d6929964498de0801fa70605 Mon Sep 17 00:00:00 2001 From: Carsten Strotmann Date: Mon, 12 Apr 2021 20:27:23 +0200 Subject: [PATCH 09/21] Tools for Bootdisk creation --- 8086/pc-baremetal/bootdisk/Makefile | 14 + 8086/pc-baremetal/bootdisk/flp144.asm | 526 ++++++++++++++++++++++ 8086/pc-baremetal/bootdisk/mkimg144.c | 612 ++++++++++++++++++++++++++ 3 files changed, 1152 insertions(+) create mode 100644 8086/pc-baremetal/bootdisk/Makefile create mode 100644 8086/pc-baremetal/bootdisk/flp144.asm create mode 100644 8086/pc-baremetal/bootdisk/mkimg144.c diff --git a/8086/pc-baremetal/bootdisk/Makefile b/8086/pc-baremetal/bootdisk/Makefile new file mode 100644 index 0000000..94ddeb3 --- /dev/null +++ b/8086/pc-baremetal/bootdisk/Makefile @@ -0,0 +1,14 @@ +TARGET = mkimg144 flp144.bin + +.PHONY: all +all: $(TARGET) + +flp144.bin: flp144.asm + nasm $< -f bin -o $@ + +mkimg144: mkimg144.c + $(CC) -o $@ $< + +.PHONY: clean +clean: + rm -f $(TARGET) diff --git a/8086/pc-baremetal/bootdisk/flp144.asm b/8086/pc-baremetal/bootdisk/flp144.asm new file mode 100644 index 0000000..41ad802 --- /dev/null +++ b/8086/pc-baremetal/bootdisk/flp144.asm @@ -0,0 +1,526 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;; +;; "BootProg" Loader v 1.5 by Alexey Frunze (c) 2000-2015 ;; +;; 2-clause BSD license. ;; +;; ;; +;; ;; +;; This is a version of boot12.asm fully ready for a 1.44MB 3"5 floppy. ;; +;; ;; +;; ;; +;; How to Compile: ;; +;; ~~~~~~~~~~~~~~~ ;; +;; nasm flp144.asm -f bin -o flp144.bin ;; +;; ;; +;; ;; +;; Features: ;; +;; ~~~~~~~~~ ;; +;; - FAT12 supported ;; +;; ;; +;; - Loads a 16-bit executable file in the MS-DOS .COM or .EXE format ;; +;; from the root directory of a disk and transfers control to it ;; +;; (the "ProgramName" variable holds the name of the file to be loaded) ;; +;; ;; +;; - Prints an error if the file isn't found or couldn't be read ;; +;; (the "RE" message stands for "Read Error", ;; +;; the "NF" message stands for "file Not Found") ;; +;; and waits for a key to be pressed, then executes the Int 19h ;; +;; instruction and lets the BIOS continue bootstrap. ;; +;; ;; +;; ;; +;; Known Limitations: ;; +;; ~~~~~~~~~~~~~~~~~~ ;; +;; - Works only on the 1st MBR partition which must be a PRI DOS partition ;; +;; with FAT12 (File System ID: 1) ;; +;; ;; +;; ;; +;; Known Bugs: ;; +;; ~~~~~~~~~~~ ;; +;; - All bugs are fixed as far as I know. The boot sector has been tested ;; +;; on the following types of diskettes: ;; +;; - 360KB 5"25 ;; +;; - 1.2MB 5"25 ;; +;; - 1.44MB 3"5 ;; +;; ;; +;; ;; +;; Memory Layout: ;; +;; ~~~~~~~~~~~~~~ ;; +;; The diagram below shows the typical memory layout. The actual location ;; +;; of the boot sector and its stack may be lower than A0000H if the BIOS ;; +;; reserves memory for its Extended BIOS Data Area just below A0000H and ;; +;; reports less than 640 KB of RAM via its Int 12H function. ;; +;; ;; +;; physical address ;; +;; +------------------------+ 00000H ;; +;; | Interrupt Vector Table | ;; +;; +------------------------+ 00400H ;; +;; | BIOS Data Area | ;; +;; +------------------------+ 00500H ;; +;; | PrtScr Status / Unused | ;; +;; +------------------------+ 00600H ;; +;; | Loaded Image | ;; +;; +------------------------+ nnnnnH ;; +;; | Available Memory | ;; +;; +------------------------+ A0000H - 512 - 2KB ;; +;; | 2KB Boot Stack | ;; +;; +------------------------+ A0000H - 512 ;; +;; | Boot Sector | ;; +;; +------------------------+ A0000H ;; +;; | Video RAM | ;; +;; ;; +;; ;; +;; Boot Image Startup (register values): ;; +;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;; +;; dl = BIOS boot drive number (e.g. 0, 80H) ;; +;; cs:ip = program entry point ;; +;; ss:sp = program stack (don't confuse with boot sector's stack) ;; +;; COM program defaults: cs = ds = es = ss = 50h, sp = 0, ip = 100h ;; +;; EXE program defaults: ds = es = 50h, other stuff depends on EXE header ;; +;; Magic numbers: ;; +;; si = 16381 (prime number 2**14-3) ;; +;; di = 32749 (prime number 2**15-19) ;; +;; bp = 65521 (prime number 2**16-15) ;; +;; The magic numbers let the program know whether it has been loaded by ;; +;; this boot sector or by MS-DOS, which may be handy for universal, bare- ;; +;; metal and MS-DOS programs. ;; +;; ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +[BITS 16] + +;;? equ 0 +ImageLoadSeg equ 60h ; <=07Fh because of "push byte ImageLoadSeg" instructions + +[SECTION .text] +[ORG 0] + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Boot sector starts here ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + jmp short start ; MS-DOS/Windows checks for this jump + nop +bsOemName DB "BootProg" ; 0x03 + +;;;;;;;;;;;;;;;;;;;;; +;; BPB starts here ;; +;;;;;;;;;;;;;;;;;;;;; + +bpbBytesPerSector DW 512 ; 0x0B +bpbSectorsPerCluster DB 1 ; 0x0D +bpbReservedSectors DW 1 ; 0x0E +bpbNumberOfFATs DB 2 ; 0x10 +bpbRootEntries DW 224 ; 0x11 +bpbTotalSectors DW 2880 ; 0x13 +bpbMedia DB 0F0h ; 0x15 +bpbSectorsPerFAT DW 9 ; 0x16 +bpbSectorsPerTrack DW 18 ; 0x18 +bpbHeadsPerCylinder DW 2 ; 0x1A +bpbHiddenSectors DD 0 ; 0x1C +bpbTotalSectorsBig DD 0 ; 0x20 + +;;;;;;;;;;;;;;;;;;; +;; BPB ends here ;; +;;;;;;;;;;;;;;;;;;; + +bsDriveNumber DB 0 ; 0x24 +bsUnused DB 0 ; 0x25 +bsExtBootSignature DB 29H ; 0x26 +bsSerialNumber DD 11223344h ; 0x27 +bsVolumeLabel DB "NO NAME " ; 0x2B +bsFileSystem DB "FAT12 " ; 0x36 + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Boot sector code starts here ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +start: + cld + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; How much RAM is there? ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + int 12h ; get conventional memory size (in KBs) + shl ax, 6 ; and convert it to 16-byte paragraphs + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Reserve memory for the boot sector and its stack ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + sub ax, 512 / 16 ; reserve 512 bytes for the boot sector code + mov es, ax ; es:0 -> top - 512 + + sub ax, 2048 / 16 ; reserve 2048 bytes for the stack + mov ss, ax ; ss:0 -> top - 512 - 2048 + mov sp, 2048 ; 2048 bytes for the stack + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Copy ourselves to top of memory ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + mov cx, 256 + mov si, 7C00h + xor di, di + mov ds, di + rep movsw + +;;;;;;;;;;;;;;;;;;;;;; +;; Jump to the copy ;; +;;;;;;;;;;;;;;;;;;;;;; + + push es + push byte main + retf + +main: + push cs + pop ds + + mov [bsDriveNumber], dl ; store BIOS boot drive number + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Reserve memory for the FAT12 image (6KB max) ;; +;; and load it in its entirety ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + mov ax, [bpbBytesPerSector] + shr ax, 4 ; ax = sector size in paragraphs + mov cx, [bpbSectorsPerFAT] ; cx = FAT size in sectors + mul cx ; ax = FAT size in paragraphs + + mov di, ss + sub di, ax + mov es, di + xor bx, bx ; es:bx -> buffer for the FAT + + mov ax, [bpbHiddenSectors] + mov dx, [bpbHiddenSectors+2] + add ax, [bpbReservedSectors] + adc dx, bx ; dx:ax = LBA + + call ReadSector + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Reserve memory for the root directory ;; +;; and load it in its entirety ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + mov bx, ax + mov di, dx ; save LBA to di:bx + + mov ax, 32 + + mov si, [bpbRootEntries] + mul si + div word [bpbBytesPerSector] + mov cx, ax ; cx = root directory size in sectors + + mov al, [bpbNumberOfFATs] + cbw + mul word [bpbSectorsPerFAT] + add ax, bx + adc dx, di ; dx:ax = LBA + + push es ; push FAT segment (2nd parameter) + + push byte ImageLoadSeg + pop es + xor bx, bx ; es:bx -> buffer for root directory + + call ReadSector + + add ax, cx + adc dx, bx ; adjust LBA for cluster data + + push dx + push ax ; push LBA for data (1st parameter) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Look for the COM/EXE file to load and run ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + mov di, bx ; es:di -> root entries array + mov dx, si ; dx = number of root entries + mov si, ProgramName ; ds:si -> program name + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Looks for a file/dir by its name ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Input: DS:SI -> file name (11 chars) ;; +;; ES:DI -> root directory array ;; +;; DX = number of root entries ;; +;; Output: SI = cluster number ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +FindName: + mov cx, 11 +FindNameCycle: + cmp byte [es:di], ch + je FindNameFailed ; end of root directory + pusha + repe cmpsb + popa + je FindNameFound + add di, 32 + dec dx + jnz FindNameCycle ; next root entry +FindNameFailed: + jmp ErrFind +FindNameFound: + mov si, [es:di+1Ah] ; si = cluster no. + +;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Load the entire file ;; +;;;;;;;;;;;;;;;;;;;;;;;;;; + +ReadNextCluster: + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Reads a FAT12 cluster ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Inout: ES:BX -> buffer ;; +;; SI = cluster no ;; +;; Output: SI = next cluster ;; +;; ES:BX -> next addr ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +ReadCluster: + mov bp, sp + + lea ax, [si-2] + xor ch, ch + mov cl, [bpbSectorsPerCluster] + ; cx = sector count + mul cx + + add ax, [bp] + adc dx, [bp+1*2] + ; dx:ax = LBA + + call ReadSector + + mov ax, [bpbBytesPerSector] + shr ax, 4 ; ax = paragraphs per sector + mul cx ; ax = paragraphs read + + mov cx, es + add cx, ax + mov es, cx ; es:bx updated + + mov ax, 3 + mul si + shr ax, 1 + xchg ax, si ; si = cluster * 3 / 2 + + push ds + mov ds, [bp+2*2] ; ds = FAT segment + mov si, [si] ; si = next cluster + pop ds + + jnc ReadClusterEven + + shr si, 4 + +ReadClusterEven: + and si, 0FFFh ; mask cluster value +ReadClusterDone: + + cmp si, 0FF8h + jc ReadNextCluster ; if not End Of File + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Type detection, .COM or .EXE? ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + push byte ImageLoadSeg + pop ds + mov ax, ds ; ax=ds=seg the file is loaded to + + cmp word [0], 5A4Dh ; "MZ" signature? + + je RelocateEXE ; yes, it's an EXE program + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Setup and run a .COM program ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + sub ax, 10h ; "org 100h" stuff :) + mov es, ax + mov ds, ax + mov ss, ax + xor sp, sp + push es + push word 100h + jmp short Run + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Relocate, setup and run a .EXE program ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +RelocateEXE: + + add ax, [08h] ; ax = image base + mov cx, [06h] ; cx = reloc items + mov bx, [18h] ; bx = reloc table pointer + + jcxz RelocationDone + +ReloCycle: + mov di, [bx] ; di = item ofs + mov dx, [bx+2] ; dx = item seg (rel) + add dx, ax ; dx = item seg (abs) + + push ds + mov ds, dx ; ds = dx + add [di], ax ; fixup + pop ds + + add bx, 4 ; point to next entry + loop ReloCycle + +RelocationDone: + + mov bx, ax + add bx, [0Eh] + mov ss, bx ; ss for EXE + mov sp, [10h] ; sp for EXE + + add ax, [16h] ; cs + push ax + push word [14h] ; ip +Run: + mov dl, [cs:bsDriveNumber] ; pass the BIOS boot drive + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Set the magic numbers so the program knows that it ;; +;; has been loaded by this bootsector and not by MS-DOS ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + mov si, 16381 ; prime number 2**14-3 + mov di, 32749 ; prime number 2**15-19 + mov bp, 65521 ; prime number 2**16-15 + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; All done, transfer control to the program now ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + retf + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Reads a sector using BIOS Int 13h fn 2 ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Input: DX:AX = LBA ;; +;; CX = sector count ;; +;; ES:BX -> buffer address ;; +;; Output: CF = 1 if error ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +ReadSector: + pusha + +ReadSectorNext: + mov di, 5 ; attempts to read + +ReadSectorRetry: + pusha + + div word [bpbSectorsPerTrack] + ; ax = LBA / SPT + ; dx = LBA % SPT = sector - 1 + + mov cx, dx + inc cx + ; cx = sector no. + + xor dx, dx + div word [bpbHeadsPerCylinder] + ; ax = (LBA / SPT) / HPC = cylinder + ; dx = (LBA / SPT) % HPC = head + + mov ch, al + ; ch = LSB 0...7 of cylinder no. + shl ah, 6 + or cl, ah + ; cl = MSB 8...9 of cylinder no. + sector no. + + mov dh, dl + ; dh = head no. + + mov dl, [bsDriveNumber] + ; dl = drive no. + + mov ax, 201h + ; al = sector count = 1 + ; ah = 2 = read function no. + + int 13h ; read sectors + jnc ReadSectorDone ; CF = 0 if no error + + xor ah, ah ; ah = 0 = reset function + int 13h ; reset drive + + popa + dec di + jnz ReadSectorRetry ; extra attempt + jmp short ErrRead + +ReadSectorDone: + popa + dec cx + jz ReadSectorDone2 ; last sector + + add bx, [bpbBytesPerSector] ; adjust offset for next sector + add ax, 1 + adc dx, 0 ; adjust LBA for next sector + jmp short ReadSectorNext + +ReadSectorDone2: + popa + ret + +;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Error Messaging Code ;; +;;;;;;;;;;;;;;;;;;;;;;;;;; + +ErrRead: + mov si, MsgErrRead + jmp short Error +ErrFind: + mov si, MsgErrFind +Error: + mov ah, 0Eh + mov bx, 7 + + lodsb + int 10h ; 1st char + lodsb + int 10h ; 2nd char + + xor ah, ah + int 16h ; wait for a key... + mov dl, [bsDriveNumber] ; restore BIOS boot drive number + int 19h ; bootstrap + +;;;;;;;;;;;;;;;;;;;;;; +;; String constants ;; +;;;;;;;;;;;;;;;;;;;;;; + +MsgErrRead db "RE" +MsgErrFind db "NF" + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Fill free space with zeroes ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + times (512-13-($-$$)) db 0 + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Name of the file to load and run ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +ProgramName db "FORTH COM" ; name and extension each must be + ; padded with spaces (11 bytes total) + +;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of the sector ID ;; +;;;;;;;;;;;;;;;;;;;;;;;;;; + + dw 0AA55h ; BIOS checks for this ID diff --git a/8086/pc-baremetal/bootdisk/mkimg144.c b/8086/pc-baremetal/bootdisk/mkimg144.c new file mode 100644 index 0000000..06a32fe --- /dev/null +++ b/8086/pc-baremetal/bootdisk/mkimg144.c @@ -0,0 +1,612 @@ +#include +#include +#include +#include +#include +#include + +typedef unsigned char uchar, uint8; +typedef unsigned short uint16; +#ifndef __SMALLER_C__ +#if UINT_MAX >= 0xFFFFFFFF +typedef unsigned uint32; +#else +typedef unsigned long uint32; +#endif +#else +typedef unsigned long uint32; +#endif +typedef unsigned uint; +typedef unsigned long ulong; + +#ifndef __SMALLER_C__ +#define C_ASSERT(expr) extern char CAssertExtern[(expr)?1:-1] +C_ASSERT(CHAR_BIT == 8); +C_ASSERT(sizeof(uint16) == 2); +C_ASSERT(sizeof(uint32) == 4); +#endif + +#pragma pack (push, 1) + +typedef struct tFATBPB1 +{ + uint16 BytesPerSector; + uint8 SectorsPerCluster; + uint16 ReservedSectorsCount; + uint8 NumberOfFATs; + uint16 RootEntriesCount; + uint16 TotalSectorsCount16; + uint8 MediaType; + uint16 SectorsPerFAT1x; + uint16 SectorsPerTrack; + uint16 HeadsPerCylinder; + uint32 HiddenSectorsCount; + uint32 TotalSectorsCount32; +} tFATBPB1; + +typedef union tFATBPB2 +{ + struct + { + uint8 DriveNumber; + uint8 reserved1; + uint8 ExtendedBootSignature; + uint32 VolumeSerialNumber; + char VolumeLabel[11]; + char FileSystemName[8]; + uchar aBootCode1x[0x1C]; + } FAT1x; + struct + { + uint32 SectorsPerFAT32; + uint16 ExtendedFlags; + uint16 FSVersion; + uint32 RootDirectoryClusterNo; + uint16 FSInfoSectorNo; + uint16 BackupBootSectorNo; + uint8 reserved[12]; + uint8 DriveNumber; + uint8 reserved1; + uint8 ExtendedBootSignature; + uint32 VolumeSerialNumber; + char VolumeLabel[11]; + char FileSystemName[8]; + } FAT32; +} tFATBPB2; + +typedef struct tFATBPB +{ + tFATBPB1 BPB1; + tFATBPB2 BPB2; +} tFATBPB; + +typedef struct tFATBootSector +{ + uchar aJump[3]; + char OEMName[8]; + tFATBPB BPB; + uchar aBootCode32[0x1A4]; + uint16 Signature0xAA55; +} tFATBootSector; + +typedef enum tFATDirEntryAttribute +{ + dea_READ_ONLY = 0x01, + dea_HIDDEN = 0x02, + dea_SYSTEM = 0x04, + dea_VOLUME_ID = 0x08, + dea_DIRECTORY = 0x10, + dea_ARCHIVE = 0x20, + dea_LONG_NAME = dea_READ_ONLY|dea_HIDDEN|dea_SYSTEM|dea_VOLUME_ID +} tFATDirEntryAttribute; + +typedef struct tFATDirectoryEntry +{ + char Name[8]; + char Extension[3]; + uint8 Attribute; + uint8 WinNTreserved; + uint8 CreationTimeSecTenths; + uint16 CreationTime2Secs; + uint16 CreationDate; + uint16 LastAccessDate; + uint16 FirstClusterHiWord; + uint16 LastWriteTime; + uint16 LastWriteDate; + uint16 FirstClusterLoWord; + uint32 Size; +} tFATDirectoryEntry; + +#define DELETED_DIR_ENTRY_MARKER 0xE5 + +#pragma pack (pop) + +#ifndef __SMALLER_C_32__ +C_ASSERT(sizeof(tFATBootSector) == 512); +C_ASSERT(sizeof(tFATDirectoryEntry) == 32); +#endif + +#define FBUF_SIZE 1024 + +char* BootSectName; + +char* OutName = "floppy.img"; + +int UniqueSerial; + +FILE* fout; + +tFATBootSector BootSector; +uint32 Fat1Lba; +uint32 SectorsPerFat; +uint32 Fats; +uint32 RootDirLba; +uint32 DirEntriesPerSector; +uint32 RootDirEntries; +uint32 RootDirSectors; +uint32 Cluster2Lba; +uint32 SectorsPerCluster; +uint32 ClusterSize; +uint32 DataSectors; +uint32 Clusters; + +uint8 FatSector[512]; +uint32 Cluster; + +tFATDirectoryEntry RootDirSector[512 / sizeof(tFATDirectoryEntry)]; +uint32 RootDirEntryIdx; + +void error(char* format, ...) +{ +#ifndef __SMALLER_C__ + va_list vl; + va_start(vl, format); +#else + void* vl = &format + 1; +#endif + + if (fout) + fclose(fout); + remove(OutName); + + puts(""); + + vprintf(format, vl); + +#ifndef __SMALLER_C__ + va_end(vl); +#endif + + exit(EXIT_FAILURE); +} + +FILE* Fopen(const char* filename, const char* mode) +{ + FILE* stream = fopen(filename, mode); + if (!stream) + error("Can't open/create file \"%s\"\n", filename); + return stream; +} + +void Fclose(FILE* stream) +{ + if (fclose(stream)) + error("Can't close a file\n"); +} + +void Fseek(FILE* stream, long offset, int whence) +{ + int r = fseek(stream, offset, whence); + if (r) + error("Can't seek a file\n"); +} + +void Fread(void* ptr, size_t size, FILE* stream) +{ + size_t r = fread(ptr, 1, size, stream); + if (r != size) + error("Can't read a file\n"); +} + +void Fwrite(const void* ptr, size_t size, FILE* stream) +{ + size_t r = fwrite(ptr, 1, size, stream); + if (r != size) + error("Can't write a file\n"); +} + +void FillWithByte(unsigned char byte, unsigned long size, FILE* stream) +{ + static unsigned char buf[FBUF_SIZE]; + memset(buf, byte, FBUF_SIZE); + while (size) + { + unsigned long csz = size; + if (csz > FBUF_SIZE) + csz = FBUF_SIZE; + Fwrite(buf, csz, stream); + size -= csz; + } +} + +// Determines binary file size portably (when stat()/fstat() aren't available) +long fsize(FILE* binaryStream) +{ + long ofs, ofs2; + int result; + + if (fseek(binaryStream, 0, SEEK_SET) != 0 || + fgetc(binaryStream) == EOF) + return 0; + + ofs = 1; + + while ((result = fseek(binaryStream, ofs, SEEK_SET)) == 0 && + (result = (fgetc(binaryStream) == EOF)) == 0 && + ofs <= LONG_MAX / 4 + 1) + ofs *= 2; + + // If the last seek failed, back up to the last successfully seekable offset + if (result != 0) + ofs /= 2; + + for (ofs2 = ofs / 2; ofs2 != 0; ofs2 /= 2) + if (fseek(binaryStream, ofs + ofs2, SEEK_SET) == 0 && + fgetc(binaryStream) != EOF) + ofs += ofs2; + + // Return -1 for files longer than LONG_MAX + if (ofs == LONG_MAX) + return -1; + + return ofs + 1; +} + +void FlushFatSector(void) +{ + uint32 ofs = (Cluster * 3 / 2) & 511; + uint32 i; + + if (ofs == 0 && (Cluster & 1) == 0) + return; + + for (i = 0; i < Fats; i++) + { + uint32 ofs = Fat1Lba + i * SectorsPerFat; + ofs += (Cluster * 3 / 2) / 512; + Fseek(fout, ofs * 512, SEEK_SET); + Fwrite(FatSector, sizeof FatSector, fout); + } + + memset(FatSector, 0, sizeof FatSector); +} + +void ChainCluster(uint32 nextCluster) +{ + uint32 ofs = (Cluster * 3 / 2) & 511; + + if (Cluster & 1) + FatSector[ofs] |= nextCluster << 4; + else + FatSector[ofs] = nextCluster; + + if (ofs == 511) + FlushFatSector(); + + ofs = (ofs + 1) & 511; + + if (Cluster & 1) + FatSector[ofs] = nextCluster >> 4; + else + FatSector[ofs] = (nextCluster >> 8) & 0xF; + + if (ofs == 511 && (Cluster & 1)) + FlushFatSector(); + + Cluster++; +} + +void FlushRootDirSector(void) +{ + uint32 ofs; + + if (RootDirEntryIdx % DirEntriesPerSector == 0) + return; + + ofs = RootDirLba + RootDirEntryIdx / DirEntriesPerSector; + + Fseek(fout, ofs * 512, SEEK_SET); + Fwrite(RootDirSector, sizeof RootDirSector, fout); +} + +void AddRootDirEntry(tFATDirectoryEntry* de) +{ + RootDirSector[RootDirEntryIdx % DirEntriesPerSector] = *de; + + if ((RootDirEntryIdx + 1) % DirEntriesPerSector == 0) + FlushRootDirSector(); + + RootDirEntryIdx++; +} + +void Init(void) +{ + if (BootSectName) + { + FILE* fsect = Fopen(BootSectName, "rb"); + Fread(&BootSector, sizeof BootSector, fsect); + Fclose(fsect); + } + else + { + memcpy(BootSector.OEMName, "BootProg", 8); + memcpy(BootSector.BPB.BPB2.FAT1x.VolumeLabel, "NO NAME ", 11); + memcpy(BootSector.BPB.BPB2.FAT1x.FileSystemName, "FAT12 ", 8); + BootSector.aJump[0] = 0xEB; // jmp short $+0x3E + BootSector.aJump[1] = 0x3C; + BootSector.aJump[2] = 0x90; // nop + // TBD??? replace the below with code to print an error message like "Not a system/bootable disk"? + BootSector.BPB.BPB2.FAT1x.aBootCode1x[0] = 0xF4; // hlt + BootSector.BPB.BPB2.FAT1x.aBootCode1x[1] = 0xEB; // jmp short $-1 + BootSector.BPB.BPB2.FAT1x.aBootCode1x[2] = 0xFD; + } + + fout = Fopen(OutName, "wb"); + + BootSector.BPB.BPB1.BytesPerSector = 512; // note, we're normally assuming 512 bytes per sector everywhere + BootSector.BPB.BPB1.SectorsPerCluster = 1; + BootSector.BPB.BPB1.ReservedSectorsCount = 1; // includes the boot sector + BootSector.BPB.BPB1.NumberOfFATs = 2; + BootSector.BPB.BPB1.RootEntriesCount = 224; // must be a multiple of 16 (16 32-byte entries in 512-byte sector) + BootSector.BPB.BPB1.TotalSectorsCount16 = 2880; + BootSector.BPB.BPB1.MediaType = 0xF0; + BootSector.BPB.BPB1.SectorsPerFAT1x = 9; + BootSector.BPB.BPB1.SectorsPerTrack = 18; + BootSector.BPB.BPB1.HeadsPerCylinder = 2; + BootSector.BPB.BPB1.HiddenSectorsCount = 0; + BootSector.BPB.BPB1.TotalSectorsCount32 = 0; + BootSector.BPB.BPB2.FAT1x.DriveNumber = 0; + BootSector.BPB.BPB2.FAT1x.reserved1 = 0; + BootSector.BPB.BPB2.FAT1x.ExtendedBootSignature = 0x29; + BootSector.BPB.BPB2.FAT1x.VolumeSerialNumber = 0x11223344; + if (UniqueSerial) + BootSector.BPB.BPB2.FAT1x.VolumeSerialNumber = time(NULL); + BootSector.Signature0xAA55 = 0xAA55; + + // Write the boot sector + Fwrite(&BootSector, sizeof BootSector, fout); + + // Zero out the rest of the image + FillWithByte(0, (BootSector.BPB.BPB1.TotalSectorsCount16 - 1) * 512UL, fout); + + // FAT12's first two entries need special initialization + ChainCluster(0xF00 | BootSector.BPB.BPB1.MediaType); + ChainCluster(0xFFF); + + // Helper variables + + Fat1Lba = BootSector.BPB.BPB1.ReservedSectorsCount; + SectorsPerFat = BootSector.BPB.BPB1.SectorsPerFAT1x; + Fats = BootSector.BPB.BPB1.NumberOfFATs; + + RootDirLba = Fat1Lba + SectorsPerFat * Fats; + DirEntriesPerSector = 512 / sizeof(tFATDirectoryEntry); + RootDirEntries = BootSector.BPB.BPB1.RootEntriesCount; + RootDirSectors = (RootDirEntries * sizeof(tFATDirectoryEntry) + 511) / 512; + + Cluster2Lba = RootDirLba + RootDirSectors; + SectorsPerCluster = BootSector.BPB.BPB1.SectorsPerCluster; + ClusterSize = SectorsPerCluster * 512; + DataSectors = BootSector.BPB.BPB1.TotalSectorsCount16 - + BootSector.BPB.BPB1.ReservedSectorsCount - SectorsPerFat * Fats - RootDirSectors; + Clusters = DataSectors / SectorsPerCluster; +} + +void Done(void) +{ + FlushFatSector(); + FlushRootDirSector(); + Fclose(fout); +} + +void NameTo8Dot3Name(const char* in, char out[8 + 3]) +{ + static const char aInvalid8Dot3NameChars[] = "\"*+,./:;<=>?[\\]|"; + int i, j; + int namelen = 0, dots = 0, extlen = 0; + + memset(out, ' ', 8 + 3); + + if (*in == '\0' || *in == '.') + goto lerr; + + for (j = i = 0; in[i]; i++) + { + int c = (unsigned char)in[i]; + if (i >= 12) // at most 12 input chars can fit into an 8.3 name + goto lerr; + if (i == 0 && c == 0xE5) + { + // 0xE5 in the first character of the name is a marker for deleted files, + // it needs to be translated to 0x05 + c = 0x05; + } + else if (c == '.') + { + if (dots++) // at most one dot allowed + goto lerr; + j = 8; // now writing extension + continue; + } + if (c <= 0x20 || strchr(aInvalid8Dot3NameChars, c) != NULL) + goto lerr; + if (dots) + { + if (++extlen > 3) // at most 3 chars in extension + goto lerr; + } + else + { + if (++namelen > 8) // at most 8 chars in name + goto lerr; + } + if (c >= 'a' && c <= 'z') + c -= 'a' - 'A'; + out[j++] = c; + } + + // TBD??? error out on the following reserved names: "COM1"-"COM9", "CON", "LPT1"-"LPT9", "NUL", "PRN"? + + return; + +lerr: + error("Can't convert \"%s\" to an 8.3 DOS name\n", in); +} + +void AddFile(char* fname) +{ + char* pslash = strrchr(fname, '/'); + char* pbackslash = strrchr(fname, '\\'); + char* pname; + char name8_3[8 + 3]; + FILE* f; + long size; + tFATDirectoryEntry de; + uint32 ofs; + + // First, find where the path ends in the file name, if any + + // In DOS/Windows paths can contain either '\\' or '/' as a separator between directories, + // choose the right-most + if (pslash && pbackslash) + { + if (pslash < pbackslash) + pslash = pbackslash; + } + else if (!pslash) + { + pslash = pbackslash; + } + // If there's no slash, it could be "c:file" + if (!pslash && ((*fname >= 'A' && *fname <= 'Z') || (*fname >= 'a' && *fname <= 'z')) && fname[1] == ':') + pslash = fname + 1; + + pname = pslash ? pslash + 1 : fname; + + // Convert the name to 8.3 + NameTo8Dot3Name(pname, name8_3); + + // TBD!!! error out on duplicate files/names + + // Copy the file + + f = Fopen(fname, "rb"); + + // Prepare the directory entry + memset(&de, 0, sizeof de); + memcpy(de.Name, name8_3, 8 + 3); + de.Attribute = dea_ARCHIVE; + de.Size = size = fsize(f); + if (RootDirEntryIdx >= RootDirEntries || + size < 0 || (unsigned long)size > Clusters * ClusterSize) + error("No space for file \"%s\"", fname); + if (size) + { + de.FirstClusterLoWord = Cluster; + de.FirstClusterHiWord = Cluster >> 16; + } + // TBD??? set file date/time to now? + de.LastWriteDate = ((1990 - 1980) << 9) | (1 << 5) | 1; // 1990/01/01 + de.LastWriteTime = (12 << 11) | (0 << 5) | (0 >> 1); // 12(PM):00:00 + + // Seek both files + Fseek(f, 0, SEEK_SET); + ofs = Cluster2Lba + (Cluster - 2) * SectorsPerCluster; + Fseek(fout, ofs * 512, SEEK_SET); + + // Copy data sectors + while (size) + { + uint8 sector[512]; + long sz = (size > 512) ? 512 : size; + + memset(sector, 0, 512); // pad with zeroes the last partial sector + Fread(sector, sz, f); + + Fwrite(sector, 512, fout); + + size -= sz; + } + + // Allocate and chain clusters in the FAT + size = de.Size; + while (size) + { + if (size > (long)ClusterSize) + { + // There's at least one more cluster in the chain + ChainCluster(Cluster + 1); + size -= ClusterSize; + } + else + { + // No more clusters, this is the last one in the chain + ChainCluster(0xFF8); + size = 0; + } + Clusters--; + } + + // Write the directory entry + AddRootDirEntry(&de); + + Fclose(f); +} + +int main(int argc, char* argv[]) +{ + int i; + + for (i = 1; i < argc; i++) + { + if (!strcmp(argv[i], "-o")) + { + if (i + 1 < argc) + { + argv[i++] = NULL; + OutName = argv[i]; + argv[i] = NULL; + continue; + } + } + else if (!strcmp(argv[i], "-bs")) + { + if (i + 1 < argc) + { + argv[i++] = NULL; + BootSectName = argv[i]; + argv[i] = NULL; + continue; + } + } + else if (!strcmp(argv[i], "-us")) + { + UniqueSerial = 1; + argv[i++] = NULL; + continue; + } + + if (argv[i][0] == '-') + error("Invalid or unsupported command line option\n"); + } + + Init(); + + for (i = 1; i < argc; i++) + if (argv[i]) + AddFile(argv[i]); + + Done(); + + return 0; +} From 904a83dcfee2f76b1e21b3ea2fc5bf5cf7e056d1 Mon Sep 17 00:00:00 2001 From: Carsten Strotmann Date: Mon, 12 Apr 2021 20:29:10 +0200 Subject: [PATCH 10/21] Bootdisk Tools License and Readme --- 8086/pc-baremetal/bootdisk/license.txt | 26 +++++ 8086/pc-baremetal/bootdisk/readme.txt | 139 +++++++++++++++++++++++++ 2 files changed, 165 insertions(+) create mode 100644 8086/pc-baremetal/bootdisk/license.txt create mode 100644 8086/pc-baremetal/bootdisk/readme.txt diff --git a/8086/pc-baremetal/bootdisk/license.txt b/8086/pc-baremetal/bootdisk/license.txt new file mode 100644 index 0000000..cc4dcc2 --- /dev/null +++ b/8086/pc-baremetal/bootdisk/license.txt @@ -0,0 +1,26 @@ +Copyright (c) 2000-2015, Alexey Frunze +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +The views and conclusions contained in the software and documentation are those +of the authors and should not be interpreted as representing official policies, +either expressed or implied, of the FreeBSD Project. diff --git a/8086/pc-baremetal/bootdisk/readme.txt b/8086/pc-baremetal/bootdisk/readme.txt new file mode 100644 index 0000000..d36ba8d --- /dev/null +++ b/8086/pc-baremetal/bootdisk/readme.txt @@ -0,0 +1,139 @@ +The "BootProg" Boot Sector + + +What is BootProg? + +BootProg is a collection of 512-byte boot sectors (for the x86 PC) capable of +loading and executing a program from a FAT12-formatted floppy or a FAT16/32- +formatted hard disk (bootable USB sticks and CDs can also be made with +BootProg). + +BootProg understands programs in the MS-DOS .COM or .EXE format. This makes +it possible to use existing 16-bit compilers such as Borland/Turbo C/C++, +Sybase/Open Watcom C/C++ and Smaller C and a variety of assemblers such as +NASM, FASM, TASM and MASM among the others. + +BootProg doesn't require that the program occupy a contiguous span of sectors +or FAT clusters or reside at a specific fixed location on the disk. BootProg +faithfully parses the root directory and the chain of FAT clusters in order to +locate the program contents. The only requirement is that the program be named +"STARTUP.BIN" (without quotes). This makes updating the program easy. You just +need to update the file and you can reboot and execute it immediately. + + +What can BootProg be used for? + +You can make a boot loader for your OS. The program that BootProg loads can be +your 2nd stage boot loader. Or, if your OS is relatively small, STARTUP.BIN +could contain the entire OS. + +You can write low-level utilities to work with your PC's hardware and load them +with BootProg without having to jump through the hoops with your Windows, Linux +or even DOS. + +You can make cool graphics demos or games that run on bare hardware. + + +What can't BootProg be used for? + +Many things. Most importantly, if you make a DOS program that uses any MS-DOS +service functions (e.g. int 21h) or data structures, it will not work when +loaded by BootProg. It must use either BIOS services (e.g. int 10h, int 16h, +int 13h and such) or access hardware directly or both. + +However, it is possible to create universal/hybrid programs that would work +both in DOS and when loaded by BootProg. BootProg will set registers si, di and +bp to the values 16381, 32749 and 65521 respectively before transferring control +to your program. Your program can then check the values in these registers and +use DOS services in DOS or something else instead on bare hardware. You can also +choose to make the program run with reduced functionality if not on DOS or +vice versa. + + +How does it work? + +Nothing special. It just finds STARTUP.BIN, loads it, performs any relocations +necessary for the .EXE type of programs, sets the magic numbers 16381, 32749 +and 65521 in registers si, di and bp respectively and passes control to your +program. + +If BootProg can't find STARTUP.BIN, it will print "NF" to the screen. If it +fails to load the file due to a read error, it will print "RE". This is how the +FAT12 and FAT16 versions of BootProg work. The FAT32 version has much less space +for these errors and so in both above cases it will simply print "E". + + +How do I put BootProg on my disk? + +If you have a 1.44MB 3"5 floppy, just format it regularly with FAT12 in DOS or +Windows and then write flp144.bin to the very first sector of the floppy with +whatever tools you find/have for that. After that you can copy STARTUP.BIN to +the floppy and off you go. + +If you want to create an image of a 1.44MB 3"5 floppy, it might be even easier. +Compile the mkimg144.c program contained here with your favorite C compiler +and use it: + + mkimg144 [option(s)] [file(s)] + + Options: + + -bs Specifies the boot sector to use, e.g. "-bs flp144.bin" + + -o Specifies the name of the output file ("floppy.img" is the + default, if this option isn't specified) + + -us Uses the current time to set the volume ID of the FAT to a unique + value (the volume ID is used to distinguish between different + removable disks and detect disk change more accurately) + +E.g: "mkimg144 -bs flp144.bin -o flp144.img -us startup.bin". +Btw, you can rename the supplied file "demo1.com" to "startup.bin" to try it +out. + +For all other cases you'll need to become a little more familiar with FAT and +a little more intimate with disk tools and BootProg's source code. + +You will need to populate the BPB's of boot16.asm and boot32.asm with the +values appropriate to the type and size of the file system that you already have +on a disk or that you intend to create on the disk. +See the source code, these places are marked with question marks, for example: + bpbBytesPerSector DW ? ; 0x0B + +The best is to format your disk with some standard tools (e.g. FORMAT.COM in +DOS), extract the BPB values from the FAT-formatted disk, put them into BootProg +and then write thusly adjusted BootProg over the original boot sector. + +You may find a disk editor handy when manipulating BPB values and/or +reading/writing boot sectors. + + +Limitations and implementation details + +boot12.asm (flp144.asm) and boot16.asm require an i80186/i80188/i80286 or a +better CPU. boot32.asm naturally requires an i80386 or a better CPU. + +boot12.asm (flp144.asm) was not tested on hard disks (but it might work as the +boot sector on FAT12 primary partitions (file system ID 1)). + +boot16.asm was written for and tested on primary FAT16 partitions (file system +IDs 4 and 6). Its expected use is the boot sector of the partition and not the +MBR. The FAT16 version may allocate up to 128KB of RAM for the entire FAT16, +leaving less room for STARTUP.BIN. But ~400KB left should still be plenty of +space for its code, data and stack. + +boot32.asm was written for and tested on primary FAT32 partitions (file system +IDs 0Bh and 0Ch) and for BIOSes supporting function 42h of int 13h (IOW, for +systems supporting HDDs larger than 8GB). Its expected use is the boot sector +of the partition and not the MBR. + +BootProg does not check the size of STARTUP.BIN and reads into memory all of its +clusters, which means that up to 32767 extra bytes may be read from the disk +and written to the memory after the last byte of STARTUP.BIN (max cluster size +is 32KB). It also means that you may append data to your program and it will be +loaded. You may create oversized .COM-style STARTUP.BIN larger than ~64KB, +however, note that the stack will naturally overwrite its contents from offset +65535 of the program segment (offset 65279 of the file) downwards. + +If your PC has the full 640KB of conventional/DOS memory, you should be able to +load program files of size of up to ~400KB. From adde7937792cc3766a38d3a0d4bd3d451b02cf93 Mon Sep 17 00:00:00 2001 From: Carsten Strotmann Date: Mon, 12 Apr 2021 20:36:18 +0200 Subject: [PATCH 11/21] Makefile: qemu and bootdisk targets --- 8086/pc-baremetal/Makefile | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/8086/pc-baremetal/Makefile b/8086/pc-baremetal/Makefile index 95f43ae..a65bdbe 100644 --- a/8086/pc-baremetal/Makefile +++ b/8086/pc-baremetal/Makefile @@ -1,6 +1,7 @@ TARGET = forth.com BASE = ../.. BLKPACK = $(BASE)/tools/blkpack +BOOTPRG = ./bootdisk .PHONY: all all: $(TARGET) @@ -11,6 +12,14 @@ all: $(TARGET) $(TARGET): kernel.fb meta.fb emu2 $(BASE)/8086/msdos/volks4th.com "include kernel.fb bye" +.PHONY: floppy +floppy: + $(BOOTPRG)/mkimg144 -bs $(BOOTPRG)/flp144.bin -o floppy.img -us $(TARGET) + +.PHONY: qemu +qemu: + qemu-system-i386 -curses -drive file=floppy.img,if=floppy,format=raw + .PHONY: clean clean: rm -f $(TARGET) meta.com *.fb From c3d3da6771c0dee85fe2b31f41c63e95f204eb5b Mon Sep 17 00:00:00 2001 From: Carsten Strotmann Date: Mon, 12 Apr 2021 20:42:46 +0200 Subject: [PATCH 12/21] Circular String Buffer --- sources/generic/csb.fth | 35 +++++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) create mode 100644 sources/generic/csb.fth diff --git a/sources/generic/csb.fth b/sources/generic/csb.fth new file mode 100644 index 0000000..974eb2d --- /dev/null +++ b/sources/generic/csb.fth @@ -0,0 +1,35 @@ +( ----- 000 ) +\\ Circular String Buffer cas 27jul20 + Wil Baden, Costa Mesa, California + Forth Dimensions July 1996 +( ----- 001 ) +\ CSB load screen cas 27jul20 + + 1 3 +thru + + + .( Circular Ring Buffer loaded. ) +( ----- 002 ) +\ Get-Buf >PAD cas 27jul20 + +1000 CONSTANT /CSB +CREATE CSB 0 , /CSB ALLOT + + : GET-BUF ( n -- c_addr ) + DUP CSB @ > IF /CSB CSB ! THEN + NEGATE CSB +! + CSB 2+ CSB @ + ; + + : >PAD ( a u -- 'a u ) + DUP GET-BUF SWAP + 2DUP >R >R MOVE R> R> ; +( ----- 003 ) +\ S" cas 27jul20 + + : S" ( "ccc" -- | c_addr u ) + ASCII " PARSE + STATE @ IF + POSTPONE SLITERAL + ELSE + >PAD + THEN ; IMMEDIATE From 38c3914fc4fee609c7033d92265eb292e36af7a9 Mon Sep 17 00:00:00 2001 From: cas Date: Mon, 12 Apr 2021 22:28:34 +0200 Subject: [PATCH 13/21] Implemented "poweroff" to shutdown PC or QEMU with APM --- 8086/pc-baremetal/Makefile | 2 +- 8086/pc-baremetal/kernel.fth | 11 ++++++++++- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/8086/pc-baremetal/Makefile b/8086/pc-baremetal/Makefile index a65bdbe..afbebea 100644 --- a/8086/pc-baremetal/Makefile +++ b/8086/pc-baremetal/Makefile @@ -18,7 +18,7 @@ floppy: .PHONY: qemu qemu: - qemu-system-i386 -curses -drive file=floppy.img,if=floppy,format=raw + qemu-system-i386 -curses -drive file=floppy.img,if=floppy,format=raw -monitor telnet:127.0.0.1:1234,server,nowait .PHONY: clean clean: diff --git a/8086/pc-baremetal/kernel.fth b/8086/pc-baremetal/kernel.fth index bbebb33..2bccdad 100644 --- a/8086/pc-baremetal/kernel.fth +++ b/8086/pc-baremetal/kernel.fth @@ -1522,7 +1522,16 @@ Target Forth also definitions ( ----- 114 ) ( ----- 115 ) - +\ APM PC Shutdown - poweroff + + CODE poweroff ( -- ) + \ Connect to APM API + $5301 # A mov R R xor $15 int + \ Try to set APM version (to 1.2) + $530E # A mov R R xor $0102 # C mov $15 int + \ Turn off the system + $5307 # A mov $01 # R mov $03 # C mov $15 int + END-CODE ( ----- 116 ) \ BIOS keyboard input ks 16 sep 88 From 497e0ab489922056f281063079b39ce3c5489bbb Mon Sep 17 00:00:00 2001 From: Carsten Strotmann Date: Mon, 19 Apr 2021 19:05:25 +0200 Subject: [PATCH 14/21] (8086pc) Implemented POSTPONE, VALUE and TO --- 8086/pc-baremetal/kernel.fth | 24 +++++++++++------------- 1 file changed, 11 insertions(+), 13 deletions(-) diff --git a/8086/pc-baremetal/kernel.fth b/8086/pc-baremetal/kernel.fth index 2bccdad..29df3a9 100644 --- a/8086/pc-baremetal/kernel.fth +++ b/8086/pc-baremetal/kernel.fth @@ -1160,10 +1160,16 @@ Target Forth also definitions ( ----- 081 ) - +\ depth rdepth postpone value to : rdepth ( -- +n ) r0 @ rp@ 2+ - 2/ ; - : depth ( -- +n ) sp@ s0 @ swap - 2/ ; + : postpone + ' dup >name c@ $40 and + IF , ELSE [compile] compile compile , THEN ; immediate + : value create , DOES> @ ; + : TO ( x "name" -- ) + ' >body state @ + IF [compile] Literal ! ELSE ! THEN ; immediate ( ----- 082 ) \ prompt quit ks 16 sep 88 @@ -1253,7 +1259,7 @@ Target Forth also definitions : .s sp@ s0 @ over - $20 umin bounds ?DO I @ u. 2 +LOOP ; ( ----- 088 ) -\ c/l l/s +\ c/l l/s &64 Constant c/l \ Screen line length &16 Constant l/s \ lines per screen @@ -1452,16 +1458,8 @@ Target Forth also definitions ( ----- 109 ) \ bye ks 11 m„r 89 - Variable return_code return_code off + : bye empty poweroff ; -| Code (bye cli A A xor A E: mov #segs # call - C: D mov D R add R D: mov 0 # I mov I W mov - $200 # C mov rep movs sti \ restore interrupts - \ $4C # A+ mov C: seg return_code #) A- mov $21 int - warmboot # call - end-code - - : bye empty page (bye ; ( ----- 110 ) \ cold ks 09 m„r 89 @@ -1523,7 +1521,7 @@ Target Forth also definitions ( ----- 115 ) \ APM PC Shutdown - poweroff - + CODE poweroff ( -- ) \ Connect to APM API $5301 # A mov R R xor $15 int From 18b56869ff582d45d77b604a09aa23fdc19219b0 Mon Sep 17 00:00:00 2001 From: Carsten Strotmann Date: Mon, 19 Apr 2021 23:17:12 +0200 Subject: [PATCH 15/21] (8086bm) Replaced "Ascii" with "char" and "[char]" --- 8086/pc-baremetal/kernel.fth | 69 ++++++++++++++++++------------------ 8086/pc-baremetal/meta.fth | 4 +-- 2 files changed, 37 insertions(+), 36 deletions(-) diff --git a/8086/pc-baremetal/kernel.fth b/8086/pc-baremetal/kernel.fth index 29df3a9..386a0b5 100644 --- a/8086/pc-baremetal/kernel.fth +++ b/8086/pc-baremetal/kernel.fth @@ -723,8 +723,8 @@ Label domove I W cmp moveup CS ?] \\ high level definition, without umlauts : capital ( char -- char') - dup Ascii a [ Ascii z 1+ ] Literal - uwithin not ?exit [ Ascii a Ascii A - ] Literal - ; + dup [char] a [ char z 1+ ] Literal + uwithin not ?exit [ char a char A - ] Literal - ; : upper ( addr len -- ) bounds ?DO I c@ capital I c! LOOP ; @@ -745,12 +745,18 @@ swap ]? C >in #) add ]? u' dp U D) W mov $2000 # W ) mov W D mov Next end-code ( ----- 053 ) -\\ (word ks 27 oct 86 +\ postpone cs 19 apr 21 + : postpone + ' dup >name c@ $40 and + IF , ELSE [compile] compile compile , THEN ; immediate + +\\ (word | : (word ( char adr0 len0 -- addr ) rot >r over swap >in @ /string r@ skip over swap r> scan >r rot over swap - r> 0<> - >in ! over - here dup >r place bl r@ count + c! r> ; + ( ----- 054 ) \ source word parse name ks 03 aug 87 @@ -765,21 +771,17 @@ swap ]? C >in #) add : name ( -- string ) bl word dup count upper exit ; ( ----- 055 ) -\ state Ascii ," "lit (" " ks 16 sep 88 +\ state char [char] ," "lit (" " cs 19 apr 21 Variable state state off - - : Ascii ( char -- n ) bl word 1+ c@ - state @ 0=exit [compile] Literal ; immediate - - : ," Ascii " parse here over 1+ allot place ; - + : char ( "char" -- c ) bl word 1+ c@ ; + : [char] ( "char" -- ) + char [compile] Literal ; immediate restrict + : ," [char] " parse here over 1+ allot place ; Code "lit ( -- addr ) D push R ) D mov D W mov W ) A- mov 0 # A+ mov A inc A R ) add Next end-code restrict \ : "lit r> r> under count + even >r >r ; restrict - : (" "lit ; restrict - : " compile (" ," align ; immediate restrict ( ----- 056 ) \ ." ( .( \ \\ hex decimal ks 12 dez 88 @@ -787,8 +789,8 @@ swap ]? C >in #) add : (." "lit count type ; restrict : ." compile (." ," align ; immediate restrict - : ( Ascii ) parse 2drop ; immediate - : .( Ascii ) parse type ; immediate + : ( [char] ) parse 2drop ; immediate + : .( [char] ) parse type ; immediate : \ >in @ negate c/l mod >in +! ; immediate : \\ b/blk >in ! ; immediate @@ -800,9 +802,10 @@ swap ]? C >in #) add ( ----- 057 ) \ number conversion: digit? accumulate convert ks 08 okt 87 - : digit? ( char -- digit true/ false ) dup Ascii 9 > - IF [ Ascii A Ascii 9 - 1- ] Literal - dup Ascii 9 > and - THEN Ascii 0 - dup base @ u< dup ?exit nip ; + : digit? ( char -- digit true/ false ) dup [char] 9 > + ( IF [ char A char 9 - 1- ] Literal - dup [char] 9 > and) + IF 7 - dup [char] 9 > and + THEN [char] 0 - dup base @ u< dup ?exit nip ; : accumulate ( +d0 adr digit -- +d1 adr ) swap >r swap base @ um* drop rot base @ um* d+ r> ; @@ -813,19 +816,19 @@ swap ]? C >in #) add \ number conversion ks 29 jun 87 | : end? ( -- flag ) >in @ 0= ; -| : char ( addr0 -- addr1 char ) count -1 >in +! ; +| : nchr ( addr0 -- addr1 char ) count -1 >in +! ; | : previous ( addr0 -- addr0 char ) 1- count ; | : punctuation? ( char -- flag ) - Ascii , over = swap Ascii . = or ; + [char] , over = swap [char] . = or ; \ : punctuation? ( char -- f ) ?" .," ; | : fixbase? ( char -- char false / newbase true ) capital - Ascii $ case? IF $10 true exit THEN - Ascii H case? IF $10 true exit THEN - Ascii & case? IF &10 true exit THEN - Ascii % case? IF 2 true exit THEN false ; + [char] $ case? IF $10 true exit THEN + [char] H case? IF $10 true exit THEN + [char] & case? IF &10 true exit THEN + [char] % case? IF 2 true exit THEN false ; ( ----- 059 ) \ number conversion: dpl ?num ?nonum ?dpl ks 27 oct 86 @@ -844,13 +847,13 @@ swap ]? C >in #) add : number? ( string -- string false / n 0< / d 0> ) base push >in push dup count >in ! dpl on - 0 >r ( +sign) 0.0 rot end? ?nonum char - Ascii - case? IF rdrop true >r end? ?nonum char THEN - fixbase? IF base ! end? ?nonum char THEN + 0 >r ( +sign) 0.0 rot end? ?nonum nchr + [char] - case? IF rdrop true >r end? ?nonum nchr THEN + fixbase? IF base ! end? ?nonum nchr THEN BEGIN digit? 0= ?nonum - BEGIN accumulate ?dpl end? ?num char digit? + BEGIN accumulate ?dpl end? ?num nchr digit? 0= UNTIL previous punctuation? 0= ?nonum - dpl off end? ?num char + dpl off end? ?num nchr REPEAT ; : number ( string -- d ) @@ -1041,7 +1044,7 @@ Target Forth also definitions : vocs voc-link BEGIN @ ?dup WHILE dup 6 - >name .name REPEAT ; - : words ( -- ) [compile] Ascii capital >r context @ + : words ( -- ) [compile] char capital >r context @ BEGIN @ dup stop? 0= and WHILE ?cr dup 2+ r@ bl = over 1+ c@ r@ = or IF .name space ELSE drop THEN @@ -1163,9 +1166,7 @@ Target Forth also definitions \ depth rdepth postpone value to : rdepth ( -- +n ) r0 @ rp@ 2+ - 2/ ; : depth ( -- +n ) sp@ s0 @ swap - 2/ ; - : postpone - ' dup >name c@ $40 and - IF , ELSE [compile] compile compile , THEN ; immediate + : value create , DOES> @ ; : TO ( x "name" -- ) ' >body state @ @@ -1238,10 +1239,10 @@ Target Forth also definitions : #> ( 32b -- addr +n ) 2drop hld @ hld over - ; - : sign ( n -- ) 0< not ?exit Ascii - hold ; + : sign ( n -- ) 0< not ?exit [char] - hold ; : # ( +d1 -- +d2) - base @ ud/mod rot dup 9 > 7 and + Ascii 0 + hold ; + base @ ud/mod rot dup 9 > 7 and + [char] 0 + hold ; : #s ( +d -- 0 0 ) BEGIN # 2dup d0= UNTIL ; ( ----- 087 ) diff --git a/8086/pc-baremetal/meta.fth b/8086/pc-baremetal/meta.fth index 9c31d34..030ef05 100644 --- a/8086/pc-baremetal/meta.fth +++ b/8086/pc-baremetal/meta.fth @@ -399,8 +399,8 @@ Tools ' trace Alias trace immediate IF T compile lit , H exit THEN T compile clit c, H ; immediate - : Ascii H bl word 1+ c@ state @ 0=exit - T [compile] Literal H ; immediate + : char H bl word 1+ c@ ; + : [char] H char T [compile] Literal H ; immediate : ['] T compile lit H ; immediate : ." T compile (." ," align H ; immediate From 52740e8949418f6615d789841fbdee855bdc1f67 Mon Sep 17 00:00:00 2001 From: Carsten Strotmann Date: Tue, 20 Apr 2021 09:36:50 +0200 Subject: [PATCH 16/21] Use adapted volks4th.com for meta compiling --- 8086/pc-baremetal/Makefile | 4 ++-- 8086/pc-baremetal/volks4th.com | Bin 0 -> 31725 bytes 2 files changed, 2 insertions(+), 2 deletions(-) create mode 100644 8086/pc-baremetal/volks4th.com diff --git a/8086/pc-baremetal/Makefile b/8086/pc-baremetal/Makefile index afbebea..d39ca1f 100644 --- a/8086/pc-baremetal/Makefile +++ b/8086/pc-baremetal/Makefile @@ -10,7 +10,7 @@ all: $(TARGET) $(BLKPACK) < $< > $@ $(TARGET): kernel.fb meta.fb - emu2 $(BASE)/8086/msdos/volks4th.com "include kernel.fb bye" + emu2 $(BASE)/8086/pc-baremetal/volks4th.com "include kernel.fb bye" .PHONY: floppy floppy: @@ -22,4 +22,4 @@ qemu: .PHONY: clean clean: - rm -f $(TARGET) meta.com *.fb + rm -f $(TARGET) meta.com *.fb floppy.img diff --git a/8086/pc-baremetal/volks4th.com b/8086/pc-baremetal/volks4th.com new file mode 100644 index 0000000000000000000000000000000000000000..072437cd75f933133c9d8d4e6c6847fa4b948491 GIT binary patch literal 31725 zcmdqKiGNhp`9FSV?wXnGkYxganS_u)l1T_*O-M4CB^ffwOlGpOg$PLqOM)cPvMI|| zmKoVZ1*=v+r53FV`oYwtMP#$avPi2UMHDP+w8o&&B9h%Y4kl zFy}gUbtEu-<;?%n|GN|ucVFwm1#J$ux1uqSZ@$`5O`HqSeTU{T(p72FPo&tCD4Aykx~)N+LupZy&} zxG3*NPGyCs5;>8gyjROR%ao77qI^IbZ1;NI-eOCc&1Lt#V~7^z<66;Dh>_TB?-*i5 z`75nd<+duFf5#9f%Dvhkhtp;62MiTuEz4F?ABIWtAeQxc3P!SC|6i&9i?otFj6kMI ztpEHp0;RK(JO%|k1ukHHOrQdQYy>jZvHq(HmJgt6mbLi`mayKyX~Jp*XgS&-za*)jSE%Gwhl?@0%=UIYxoK4A^Vz8gJg8 zQ8318rK0b#I{7fG^%i_dFoJvx$Y<|=$> zvNF35V4XaeFQm|adX{`mz@x3vslc5T;xnQ{+K+_fgYu5A1z#al{11DN5 z+(kt$`-_y5spdS1oM$-B;c|N3;~ws%8uoG_@|&Ed;3J^=4H4W#{s75XPHGr`^M-w<+ zg^c1u<#e9&Ra-p8e2sS-wVK0+$@x5MtMp9gy##Or;N!V`Ko;@(lkFM>I-3ud=kgpK zn6>=2XGJoo z-}?vqZ7Z{IkoqZQCLpwfIiDtP_3`Z@%E zB}Z8g34`Sg0$b*;cuBZ%k|56lvP)nsWww1nP2vdxy$(>Ppmlps2sL^Iau|>g1h&TQ z{Yt1AtAIWgqU65`n$+)w8dd>Z1>hfoP-ZW(RM>Umjnh=sj{x=wn)EoaCiQ?aj&Lzr z9xRGB6)#J?akA#dsU@0151}U@bEK%XrA`%VYU|kdJ%c_XaK0ELTSe`d)OxXyzN_#( zP1I(k-YXV%e-k6m7qw$kS0epgjC`M{%}(7w=}lr`VfT#~c@0XY|5BVvB^yz4J4&Yi zPMk_5cL6*7_u|y4-954L9+9i?R@xg4eSNX=A4T3_aryAYFtKu%sL51Qr$o(|MuP^h z^P(oJ(V#`@Yf&?{(ZC{gUDRYZ8aSjFNt+Hts!Atm-DN|iH~aehH#ex8{aGmTfJP+wCdgPbGDRzPbd@5aHMO!p;&?2+CF!0xrU=-62# zrtc4eO|N5G!Yoo|n83A!RZG^ecrH%9N780ac~sJ$e4Al9G|KQ@Qk)!+*v#C#->L9+ z75*#0e=TV%a}P*ZC*ZfK@ZSUe4&ZsGrESx?FAS0YB586j_T#KnagIwv3PTX)|+Uf|NciRq?M$L*?)w&6M<@nw%4NyOtO2D8q>Ws32fQ7+f5O|iKb>S|VfzpA9f;n*+%x0hH_l6s>54lC6e<+(aJ zCEw=Wro$w6e8Og{cK|Xr=+>cS7kGwObZZYP1AYeJ|IrDBZV*A=AzjTj_JGo>H*_ZX zE!{&Yg#0&MpSYOy->*=SqsaJ3_i#!o<@})2#7yh{DnY)g(>S$y+>mUwmge!IEFH$O?n@1#lbwy)%=&-yQGE%)N4$2A-BLjvGwTb22{=3W zaAjGA69j=OBiKl}Blv*LO@R5jnfjY(d8E7{_#k!!!M5CiJr#V2*3fLYsdWA`T}#+Y zIvUqVc~9_RWqk+ouKg_U!{CQpc1xB0yI^b~|NXbi%G8A{*C)%Dg4xQ_(fW{WwKvWw z+o&%%S!P4DrK5)v?1};#9Fi=@hG<5c4M8EZRU!VaX*D;#+oqH(LRLu#ujDMIoQ)T=F4X)&cjI4b{yiZ#{sqRMx0wB?`bgx(s9MeGN+*7q;FX&yA9|q5~NRLO!}l9as}G zT7D-)lVLXO2ze3x8!i7ighf5{P5m7$pAO+iQ_W^WCmSEq#kPbH^lFH9Gz#_h7h*#B zN)_o0wr7Qc5*8{{+6GFV5zn#}DDB`omEU+SRZa}$t);lT%R(Rbch$|B*1JpL4E_|7 zD%(N@B`a@!f1Z>57yF$BJjUa-FVo$jyU!O-UbyjeS|yr}zf zn!GlY_qZ%p?8IM%ZoCkj}UnmEz-gPc?TW#I6-WLh{ zSAb82^0+-99_0*mvBY|I zvd1|h3mNjiYx$BwYJ`uiH%mbSGwEHWyhSa$n7^PJX2t*++w zh9&h2jXB2VMT;8dHrKZ|Kso~4TYt5y!a;Bjb_;E-HK-paN!pyu2iWt9E;_nU+UL5d?TTg7;Xww0%3-U64jb>dP^6M3Aoa0{`>6J#+`o0ecUR7(k+5p;FcVXyDS>6suW zMal`_?usLEi{c3Kdzk`_NJF0)F+t9cT$6%gj!43s5&0g{En)SMqwzgaZjM}=VpejG zgkDc2$kNCI1ZW9+uph-AX-T10M|DOt;vh|wpNcFr4?xs1FGpHt;0nS-NaBUWFGJK} zPn6${ES!OixTGHJRVw;vq^%hA-)y)P@xjm+`4=#*iSp%0VMdwVZo`fGZKQ=esC4Y7 zNVeEsL+ysYs#Oa|4ias4tFx3?*lJ0qf+xvIg9IBCMiu$Q*j7uEew1wbaHd)kX&IF7 zKM2)QCVjoCJpfp49fpG4mh(<9R7Ni>`z?;6C~JUE$s zec&;;Yiu^QpH0s(nc`!7Hg6w%oU0QTVAR?CA*G{)(0&=j+4%Sd{#^7HuD&NXwag;#|BkP>D0AQ z<{EnlnJVx)W+|AVwNk(BgSJYG2Frt14n8!yj5^Le5le%k z)B+4?id-DU6+3NM=xI?F?geNbO5%=lw6~_njZuQvUS+4PrDopES{?NPv}%=JpOZH3 z#we|HAHS44CamT+VPdJ0r=o(KrKNV8Q`t?`Qo$=go+2NKlE6oTzFM(!s-;x~ z&67Wm(pkX_d2#%$CE93zqomw$HIaGpwJ4!jx%kY6)!4BrlRAQJ#SVT=`ZCyH9lmtTrLY;)Uv zc|HRmcm+b2^h*B-lZrZ(}jM{3y{cCC?V*ZPO&obI^r$V#pMQ@^4L{5Hla>tgvl^^W-o3tx-- zY$&r#;BW~!_=s4#-z4TF-zW&2S^s4p(LbwfjTKU;43_OkXtgx_56W(_%J;|e{oq=D zRjdQs9K-p8V8OglvCU|z&}{=d(hBlnm0yYF=@YfQpnUI(<;`kWsM(=RE#Dk%(~Hc5 zk=hl;{)Vonn$e*LBia1?{Pu)+&L$s=71f29O!KiQiq>Iz+&K;`@G#2f3>xHw8s3N| z-S#6L%1q|R+T;<2_i~7nBryui&@kG&HhGFc0=dTND#NLhv96eYzdHSs40hRP5Gwo6 zSS@b=BiM^eqVE)lOGsrKc)KMH^~T1Ig$pUm0fcx=m|b3C;3|D~FICthE;m@I(v6kc zPKH%<&Ml~Tw*gG6(}K%Pj-f4BJ1~1hF-STa1_4Y2-NgP_6-%ebY&Zl#lAp7rzHJ^g z@}YsZ*&S*t7U?Ggb=|*G+n3~!L*lemo=Y(tV;CYS|5uq!hnx~8f<$@kWgvvo5Ql8R zx4R4~U<^Jzt`-{BUV#>izFNiUaq*l(E|24&se)vej+w@V`lIx%DXOYHlz#@0G~C4a>ftQV+x&R&I%{?fZ0F;C{em@ zHmJvg$p32o4d|KacAz`xYuq+w!*N^;C9$92<|vjuLwN9gv=HfW>o92`j=K4}P=?X3 zA3`I(rh7@(Bd$v*iCd3Wi{;0Ma2Pq7qb6wUM_}uN1ji~hn)Tgip;$gLgeP_qXkn3` zfnTJ)(KcD0x>X{bTpIIeDoH12+3bYWAY${Da%WlM7)YxBB(^=ljH^AHH|x9l=n7X! z`BJWvT@`y4S27MN-Tic<)8{Jnb0@eM+(_z&gq`4&zaGM;V2*4Lf|aiGZsd#npT5ED z9iDK=pRK>%K5U~)oABq!f9m+I%6}8&|Jw7jIxgbZe;XRFZm8s;V{^|^B)#_yC3445 zNP1;9nrhl@t9hDWQbcgf3*tUNRt_Z!^dg@(RKS6H0e4w?9OeHVgCH)XL_RQ7gNvIu z!%^I~xZ?@N$A2)rUuv5Pp+BB3lM>kwe{g!T@=cs^iJTFyFROI9R2fF$1DA4J!RJ{N zKF=lR$4gLMJ4jJwiu)qoZ1`X(El)fsHcg1YRDsq1))WlUZgKO%24ic>!lh3S9>vX% zr^!{3!x;&^RZ&S{O1ua$nkv-6FO(Kaf>NSXu8R*TbDI@qolo6>#K%)<;$76SmCDEC z1x1YTn&MjGOXVNpgPb_AUXRy~L(2@m6j2&aQ}&HE3l-mvH!C}|ROW_Rri0CsTHE>*?XJA55*(aa$rPvPuUcB$jdL3s8IWaH-67NRUfSmQaj>>noNtNhP!zau#HP+Kt1XxhZfmakp`$@e>? zf`ZgTOB7|}zM+>>zoL5dDp_h+w77jK@hDwv7fYS;$Tx<`o=RUajn;u%n56qocGB=p z7Md1h+lPy0lC>&*rnrApdgQsod8jB!NuWvYWJ&bvWWO0fe@P(hWJ#Q%zvsAH_@_x; z7;%nk86G~YOM!I(>m1jG67-kyy4W*FQ%mi`Ikn;i*nwxn6~p7Xa{1VB9(plqj;ik! zK31S#4d*I~y_Fh3KPbsf-qK0>k$>HI{%=&-! z5!zuRpGfA0ibJ#8P{DLu_^U2*tJ>Azfi`VANz`bOVk~M$Sa*`{Q zas^WmG|=f4Ug(~(Oz#$I_q_bp6MYJUB(1mK+EDsacP}wlK6!*mNLFmkrnp~deR7$J zSH7UZH!;!GropCOG*=-SOLW*L&HXE*CZ+(N?YOtw2 zK??gMmSp7ighx{cGzOu}auX?Gj&l#=SFJT*T9=|Ur%2Tf(1=i`lVzg2*t6PZkQovc zNE)XciMb1_ls_~b87SBi_OXcs^h%jeIHGh$5y`*p2gW663tf!{BU347Bm~ivIN=3Q zL@fOoaf>bvj9;&?6Zb}TLaaz6_}k!}qPnXp<;e*=G)<)V$WHhY>sTo-Ob`?Zjy)BZ znDzt}8RAM9v2<1P0|{KQ+l9>=COwf5&p(lHoFm;|mHb?SHaF31cp~A61ls&n^4kg8 zMC{5&fpDHkAc2CwA0}`wCu20k?PtEx*@r*cM zHv&hKffe9B42Q5%lNtSm#LSRh;Xu2#O02$dCB*99ZIRlW_4 z0^6cpdzkCHP%GDu0I{;dNJ7{4RPY&eO=a@}I1;+DB&K-;X*i~WrqTk}%F9QNLU8&V{ra})@?SmB4z6ugE0Un*o8%IeEHlOcIn6p&Zxga$1ru-{$m{ zC@@o;aoh|!CrL=Ly1n-N+N2tf{$vNsIzs(|BTVNTpPBW$Rggi2j2P z<$5_jV%@(e=NrPg?C1T_w?=G;+JHhp_5W)FUvuT2vouEmur*PbqdbPhaZ;?<^a;4~ z0^(}LnSsRe;~@GYlZacpC>AG~_2>K6DYzD?@4-JnUqB*ZJU2@&OOouMxV0EGiBh$E zoU~4)`J{$4BRkn;!dB_mI2v>qR`bNoNxi~J$fRoRJxc9=>m&UX%q=6-6^mqun{ScAOhu@R^ls`f0d%+=s}2P!{{OM-4NYX0_!H%6%SQ9VSy?v9$QNpIhqh(Q7c4 z-aGg!l6i+q;WI+PVGQ8RoZ~B!|2^^vlz_nyqS=W{_sD0H z^@`v*Fu;q+$2qzSW5wX4R&l>HiVIGX#EZ%CJmpa9)EC+{Hx>Tk9{KBJox^Ll|Ga`z z$-zmu%RxfS3>AAmN!<>VrYk_grXXV=ebc>v4vkO~)LC;1b?EN!3Fl@q{iW^Gi>TG$q3?c;041M@-3J+EzvO_FuWB_(SS01tDRgImmXHSEavyPJw9#KpvFT%R zEz+ib8)+SL7Sc;+Y^;v1T(f?k(x^9@1Sxfn!?6yX>>J{rQz)NgwYl=j6e#V;Xr&S_ zT8eC-QB$GNkE&fTL+rk(q^Xl6gsYQDyy=S&qK-iRpkWNiYy%DDj~Zx5J)6hjl%yDv z3{zn|dV17Umgd!rtM=(p4rtPfF;{VD{pnFpkD}|~1^k~#!a2-4$2>iX#5K~NQ%m`y zn&al{j3~?Kk8>w^DyxHXKpMj6&ndz*-5kpVQh`t|3E0vQRe)`f$BzoJR{AR3rRnPE ziOXq_(?`P##aU`L6rlRm{O?9}k6JxycixoIq}q!WW1>kFRTxF&rBSwy<`v~5>AY(B zsqECzluJ2_M~f*CsEbGjp{e}X6x7^iY+JhMp4NqfM@=0~I2%U`11KaWK$OssULB~5 zm$bGw%xQ0!TN10T!_TDvD*DQ3UO8;U+)*iN+9Hib%Aj!ZP4bn|9GzV18D&mo2WjA~ zqH%?)a{C)1E#C|OA-6Zl`cy8_?z1);hA?KsnlxwX;viyJBbl^JH6>ve#EPT1Ln4XH zO>$u>EH7@-h;B-wZCaXIno6XsNp4GJ^R2l0r=(p-JSAB;Vs=T7QOjGQ(1hmV($%Hh zAF(rgg=WmzJo%ASQT2rE*H2wJa`lhObk39arE+%AftOR6dGcqeTC4ZvRP8+ZLMm5L z>#@I_io)NfvNpTx4uGa%%8Ad1xB^(yGmd zgf!Z-^W@|-*6N1JIw6hpdH>c&EBe^=vp!Bp6BPfyEhCZ%K6JTwDnzuX+Ej^kB-xH7BT2Y=RG{Z@k^C`M=i)0u=JE~cJHEjgxVp4`Q z%Lmeu6qSsC^wG2=McMH^(x0V`Abrz{xMul6TI$dAGqZ-wm!C_Ml1WQ$@j_1cg_icm zQRA#(my99l7AY0`<1D&sk$$0_HLTV|eEeWj_%PzQ=gZo3J{i*h(Vof;(oAL54FlZ= zDH}bUu9J-lKg(_m#RUhUjYK69I_3}gRm$FE+z~@U(yFD{bqP^gV(_n~Mx;Kj+yvF^d+j{UFCj8*dTVwZcI(7N)eSt3a^rnMvG1`3$sINFY?p9K3wIZ{MKwz@Iju%%&55bG&BlVS%*#{#iQ34L3M>p*$rW9=pn*KS^IC z|1(_=*}u|TR!8$rTv43)CfeM8d9m8&-;@T?aPMz^-0Lzw8*M&ny8Kw*B3UrAg|#>{ zdy~H#9g-Gnj^{3W`q1_%l+Es2d(g6X>QPghctnUchj+i^&qHV47xqPI-ZC=1zu8xk zex<6fMJ_ONG>t9h#qvXD)@3c&VIHm;^r*Z6O)=P5^F`F@L1 zzcXuH1xKlnKWd=J0l<#{Zn~h9*l@SRY4g4ESu^jVlb{M7;R-?Q6&^Q#sc^7FF7K89 z2^=EwBQwaaL7X)lt_fW4u5R5OCx%;(qcu#k(vk1YmtsPgCGyY=J_Vb(U}gq53wMU@ zdWW!AJZjo_qLW!a-jhMYDalwO`&6`i`3~Bk*ZcMgM@=0Z9OuNneZO{RboOohgz)dn zXp@&^=u~b2b^G4Rc#{b}YC0l#G8BKa=YjBI21o6h4b3CgWZ3jK`=)1*>5bA7Gd)9s z(e4b$Oo#ko2A5c9hg2Xk9rE`XY+@m#0tsnNCY%v0g^h+Fe1v4Oi7xQOI;7)}wt5>4 zAxMwR6jRjmX*P%;adfef!b_936D<(YQz1d&=U@vFpvfSa@GQ9aP2lssOs!M;kcC>* za}A9TFwfv_Cf@?OD0R%5w5QUDX`prJkbjXWVO)i7Nay#aoy=I1k(;?D^FDc3rf4m; zctHT)&s=r0uS0vgi>7bdyUimoWAZzhyfp(vtI^sRM-9T$}wDp(*qM4 zNprza$t>m64M~}s#)uF%-~m&6EcKN4&5921oQm@mUwdPHzmR`7hJzB)bYje29y35& z=KYLc$nTF~J=TH?W4_*aB1`de_-xEC8@XSthq<>EN_su|j8V_g#wF!|mb5 z3>h;dYzRnN)<@^xeKd>hck0$;y`Hu4z_eOlWtIQ4x3tVh=Z_}Mnl*DeIe-cqFaCN$ zlHxk~O4eupi8iwPQySX?S;XeT+Hg<9($m4kmGcbRYs8sbitxCD-I@ajtcDyvtZs#N|C<-kf6ZGdzd2U2RDg#otc0W>f{l4FQi58x zb%`<2NEY~vLF1B0AwV}hrK+V!I^`T#-HYPlAgD$gNqMcBJ9`vJr~)AsZ)0mm%iNnP zaB+S6JmVc8CsEl!?X9iGMfEL9jjf9tT8vb#tyZkwgxO+ zYomf&Ern4|Nb|yl4NY*2QdSf$4Frss(*fmj3)IZbOTZkqE?HVFMNo$R{w1v~O)73S z|6n9%Yi?UGIJ?0V&pjyf*}9ZFa=qC=s??{)l14(uj7vJlWn>HBZ(PIwh<}4kJHd*F zz?#UxY&X{o6sS<{Ujiqs!PyT+hQKweeaX^%W6IKumQiccaPr}HQJbn5b;bI7T9<%f zjptU$gU0a>xIOl=E#tQBoigpHY1sN;c>zPiiL8|IDgmP-0sg;$-g0x z%k8rt9JlWD-n^rxb$?Ng^K;`?%Woo25&OOX`n0`eM@@7-G>R|O3FQBEocI6~DTv-- z#_zRsf4N%z9uOZkm$f2t{NB)h3ep2qVZ87F%|-s`@!q`#^%5iMGGzQ3dH8t#0g3~% zBg_5sHYOl5XFP|3-um(W+q3o-9X0uH-0effcw!h=gQ@Kmz|=;5xfBd-JhxV^8P7S) zW$rcOwQJ=^#!C*f8pg9`JiAujIbLv>N#Rq0YKJ^2G<<9O~Nxq5<>f~Y5p*9tZI!LeyswS0K?aqjbRl(}_+ z*q>*L`vd4P?M)9%y}3CgFsCt#qDV7voC}3W^Bnf<%E@F1CR6-?40dqrkx&WFTcn(O zSbk-K0C^rUR{!2jI@<4zBN}yP{F@X0FhQPhmOVCJ2Nmh#V29cLV#OV{`xphC*PJ5Fn#E$r4iKuMZ z_VL>;fA9fyXx$gJ(}wTOKWYkmu<0}Z7u!?=%-V^UUsSVY-$cRXfQ0CKORc;6=sNk8 ziLBiXKBcd3oqS*-PuW)Tk2@odU>AeyxQH9-_Y+6Kihu^>W5592R6>AY0iD>zeu7R( zll(W;#tW!p+XBZoeF1CGSf$z2k2=(j{(9nN(+8kRL@dZF6PBd)au0P0;b%S<>cDWj zf4^R~OyUWobmML(rcNT+X}w&DTyz0jkY<>=FmqBow?S^3BtY*7jp*Z(w$=JS`sngU zr|I9uPaf`BeXfsHB6`v$ZIJzwgwYD#zDZ;EKm5tV7f<~Cqm%ScaW{T-64e_8$-Q3% z3+JV==eWO2s^$MMiRjq$iHq5jJf)6}|AE^+i5z?WGD+Q+aY+P^=Qhg!J4tjXjbNtE zPx}2t>iR}Gc5*)yoj*TmD!T2LXOHDlpdy9a4=N?)9?8DMawbeZ35IZ@^0yP7VR2)- zv*>mcm_1nn_bIMNGJrjYGB6%M!9)fvs<3b}-0I-?giU!yTsb+O3&@X7CU0KwP;v}y za4C#7IN9~#99YW_3%e0YVA4WvAHNiw$ZCH3_)UsmPQTN~WBeHqHV~WN{7tR#`N=vc zZp*;X!4mWBWQNh)y&Hd)a~F6g6_EcqnV$}dGPBX}?c{)Lp3Ixo&Z!!?Be7(~7q|x_ z1@+pA=N^%>bCfj)Ur4HSf;8oQa|DY|HEd{-Yx&s|E=4%_e~y0@m2Z;Y%3+~$SN#IXtW9($7_0`_6knd~ ziFy(C4wY)Gh7#qe$z`_YB%MoF0Be!&N-9w z@$hGqjO<*|S!Q)rl84qsF+Vq++boyn^8NgeCYjbge7wMQXZ;$cWwQ8?OT(}56|b;S zgkPV_Dh!m0odRr96~~PwJ;P>sYp&GKDnicDB-4x&Z${KrrL9C})O`(8Kj@yoRgI;M zCdZJ=%$4UqTgo*n{dzT5Ynl9yTxPTUuUu^*Qku;&J4I_nO1oJOnWD8J#cq~krfBU* zp>5L?tph23vz$6bTZELbSsph^K4uBd|PaPFqCQzev3;jcJ@giIJ zauarpvZsUMf1ENgPqk8SlebUd)b?xgZiA=XCb#FobI=8`rzQ{9D0G;>*u8g@r}RZ_ zse^hlk2VtRdD6#*viYMl$xr6Jhym*u!cvLJagJb+OOsW?(kefcCn@S7L^PAHA0oW- z?sCqU?QbWGIa-D}?U`~fPW#}0%e!;@2NIg~Kjq;BmYN-f-%bwAXBp-L&uYq?(GML! z{EuI=VSk7^&orp~5c)r*?#saK65!= zdpV!GoG)C?m$<;8e2s-{23$ZY&_J1~K`OF9W21OME-bdYGi>1QX7X7;Pr0&N9a zE0RG-K2V^wA*n-hLxI+dq#nubz)fv51S9z?;364<`pyC_ z@F5bZhmrVe0nRQ)rQrgfqcoBlBrg|eeMoANyoQR9WHn@qze6Nef4r0vEi{8%;C2C5 zSX*HqWI+Q)+^O)N8e~DqGz;sncn4Xuq%5P->Mw^{M9Xo`t`sL-;wpqY()l9WGku){ zr%U$zu@?FrYa!1PvERRwAQo<=l4D0LJH^d+(mi4-d}m2K6F8nioXD-5lTJyi!Ql}7 z-fVf*(km=QuZ6%wizbmcA|ddJMVmOP(Qt$j0$*CR*3l}o+oBl-9?1e1F%sm0m@_aU zKTKBJ{bWcH0@p2CCosqo9z+e@6i-Q;f!?1TQ>e8m6|ClGT2vqM0<)f1btqJRd?9P2 z3WgTm#aN|c6sR*$%U`e%xe#EgB$F@drip^5nChv%YQR(d{z4*YPE5yUixbo8;7j`_ z7cS#SQ5m?eSup2Wl0_0R-!zZ?HB$1^LR3z(2Y+)*oa6*vEq@xVZ?=3|NJQh=!jqyI zJ$bwEkZ3`bo$P4~%}X@X1&!|hRp$g+jXLP?%Pj(DL7MC@UF^#IPL^trP=gs}rCNSn zJ~?&~Hr1~7My+{eeiwTT)45+AJ~gn}GSD3hx-`(0atoPl-ljee%v6-p_vftYZcuy_ zXfV~%#DTHCX1(imMq>xX4bH}eHf#iDhwaHaTLi>*Lkb>cB0(?&Ji$j?)Lsa6%Ddc$5Z zo>W|(3ZJvu^z)eWn89S`AkrqxDIt?c4HW?O{Hq%0EfDY+nScNQ!isjkvv2|Fw*jU>%{Kj+oKy@K&vDw;f%qo502OHwX+ien~ z4`}QFTib2n00-MyUtwXpEf(omz{`Mc1kMP+D*;adJkw4A=Iypjz;o@awbavYo46`C zP;5u!9dtn7C<9Da1~`;?%~~z(p-U9SKI?)TDAC^~nC8SX&-4|AKjm z!Dry^O3-Z3P^zW%17jkA=RWHb3U(CpHkuMtMG~zB%^Xc~gwhAkF=VMgLZSGN&7`=1 z&kId%pIUc37aXXtbE;e08S#BP0fstQ55-=h?*vdArJ4=>i=ehpaJPkO>2|PpTV?S;T%2MeB&Sbh4wLxX=h4xhNf7p&(CY1~^eSDUefOR?()YFh1J zU3T9Sjzb}Vw<&3P!tqE*;4qRlKo5roPB^$4YcYJ2)OyH7t4@BJauC#wvM&D+j=mlc zJ))2(%R6zxzo4$QE)*`L~)|-JXmY{602;~gX*4Z80znRd#fqf<49R~Hi9J}WL z(KtG3U(*T&D?17Q>e2n#{F#o?{PlnWQcpl)L2|356R|(rDB%HTF)WU*wqhncu#=MBwqhwf zunS2mpyAB|I<+X*i)@ zFMcs1FwV&ng8=Jhf7Mo0O{)|Uus9WeYbA?Z>93?5g@1#RHN%NfTgsgiA_DhQ(zej~ zu`VL8hSH@Aoqt7o6QzCS&ishLlTOxJSY7Vi5fS(ek}hkx^PdrcJ(RSSJ8wk<-l3$k z+<7x1a0JOxAp8&!_z1~rAnc3?oN=-?YA-n=aEX$rHzOj@>tu^v73I$FBLY7;IV_*M z+<7b_AWh{Ue*=CzA~1L=f}DyS<<4J41dK>SJyGuLi3p@k#hVr~*)) zjtE$%@`_Yj?tCgD;GPPDI+cAUA~0hr>#IPw{uL3JM@e++r-(osCDHF6BLWXh<*F@C zH2TYkz=o+@4FcoJou5Vo9-GQ4eK{Brcn<9==?^0UFA*5+_eKQXoGRdbh=H$zQ~As( z%EvXLPvsW%D)%wJ2BR_*7mT_&ud2+*lQ(c3-c)XxpYq9FmGUWWM7>DpFm;Xp}v=i46G{AT9Ir+(qDp?Fd7XVNIqVo%|r5jB%cE`x6!Z^$(KsB9=!Ci9Le98 zXaHP^)PWLhE>Ist^3Nr#m1;PT^rt0UzVh)UKE5iUw^T?xC+1>Mpr?dO#hemBK0voE z!59}DhWmkCDv)@JnHEGMwRW_V=6y*$#6rRy?9%4LDg0*sPnZ<~6u7iAq2~B0pW+8% z#blR*XA3B!92vmGgxUeCauIC4i_M=7AVKK+0hg9Oe^R=!301?h{06F4Yob#%DDX?v z12F1&R;lB47dw+${Jo3n92_{{;z%ovM-rUD1>S=54sXFtOGn91`32A;+{9mE><0%< zy0n#W`VWflj3u6VaNyB=$qp}HlCjK&H{&SKV{qVKE;h%C1MJbBwltKG6H8R78Wt24 z(3Rem(-4xbkjbb(PN}^=Moo)G+eZJZaapTbjxQDA4TW<4f*Ko$U2g=)=UGpmlJV)oxi^#=<5|PBF1C zsj5(R%m0*VE3xS0?HbRqTiz_QT5Pb`(sJI7TxPetUnVG?%_(Ms4Y&O3ktA+ujizTK zsni!`K^AXOWhsJ};HcMX+$mBd(x7D>#`_yunwuJop86%Q2O#1eqTrUF%7R?vKSx6L zB)89hdT%jY8-#5&zDK+H>7IUj&73lBORAf9k)K?hTiA49uM=48wr&;(N@#Sso8MCD zhB+FBl}5v}Vf>c+-9i<@L)`^i+<5$JZ`jfBb$@xC$ra%Vu&0|{b>vMlxwN6!L+&8b z3@ONT1a3}nlk`DxECRR5jp>2PBdqhS&$8UMX9ZXIh@R;l`L6Q`CY7;6U&2+0S zXf!LKK0G1-qZmfN5T_eb+?LPXf(1eIWwsO#9`D-7a}**m>~+oqH8w)M*?+E&QZ)E4 zx`i$A9sxE)i?z4{xV8RIW^Lp*eyKf&0^hu*6iCYY`^K-?ea0eBc5!;{Q8#0 zhID*AGHHv`Bj%O5%PNYoOgF{MkQc<2 zo?d}o2|3`|wlVk(hW*Ze+woKHE4Ml{7WMUkI+>2_T`2ayfq0HBwFxV&&@C%8I;-1d-Q5mM(YNnS~MsZR( zu{9RyriYjwfgukFILwvP7x`~)h1V=WCYPr|Ax{=^&HC)}Ah3WHPBYfz+sQqp{GIby zd^h92p2zJ=$~g-nM&B_QHQQe<7jVuHQ$mrb_*bso{#H3p*$TfwVQ=&g!lI)1eEHDc zaw2@%?SC$p5bJ|yfAFG0c`V1oh}!MF<$MYiCCWq^qdIanTXtwEx3`=$MtGdb%fxv# zab9hlm(^|;ytvjXD&oATZk$)BM)(yuhh=&<;RP~sgVk=gcsU0Gqv+=A$$UYa>cx56 zUgPCc$m!;OZ(Wtof1k0^f0Z`-#u?mR_Goyy_pQ*-y_%!p{=si)7<*}Z)L!k;@Y@F_ zNB=#uJqS@^dxMUKcVFHxcv{Z*Kb3cA{evmLmP*Wo`*+{S<`L}nMQB3x>=?mb6g#}M zzq#!vyyT;sNL%eL>3Oa4_&HdiVkOUwlF#9=I%4F8ia-!n&d?J@2R(tXg5iJSJbB~Vs?7W`{(NJTs+Zr4=wyUfJ; zRK@L1ahdS7H#^~!_iL{jk0NfLQ6azrg9qjU)HpS~l0&rY#;dO}8?o@WyWZ3YcNXZ^ zK5_f%3e`C$)|U+q12NCur5ySD>X?lc*~*tkY5nzz0mqwkU=Y@P#ihnm5hkhO5z_Y4 z6}-7nc@Bo+Kr#l^@)X&izV9Gyzg@waePGrQiezkSHIlmr9@YQ?42Ii>R`Mxk#Zpl% zLGSh@1uRX5SD>_gQYDKFwHTr&ER_WGRdQr$Qg!vDnWs<-W8uODw-A&YtbQT#f_^(bt`s&e=re&AUG^*K}A5B+a63^2`(+$tD|@mwHT za47EWuJKQ^qrHl?RX`KH3W`*`TS2oSEoKjnt(I~}WE>nDmW9Nrpo3%gh8|SxI;v@2 zwfxhe-KJOxr<$Ei?q=+czg2;w^uQK&QJh&#fOo3}<*g8asBLPE zoUl9D6;%}KLmZAK`32}pS5zS`41M}J>=@j;$aqQ`UkMs(QUZKz;#yz?qR2*Sfdm0V zG6F`Dipn&}$Hv$4KX7qLXV9(3cpYA%(IiiV#g^M~q8g&JSD`;aZnEXYGH>TPc=Btb zP{Yg`8s9THDiz>&WajY>a_68eu^+}fgfzv3zDU~O81RVvj&(J>Lk+mlB)>k856LTr z+-&KB;&=SEhBsF$kDaM5ORv^E2DSBlh+@*1VfpM&(eLJ(e)wedFbg}nYH*lg(xuT& z%^@xcW=)u*tEG_LWjNT)ZJK1VF%mwF`Um77qU&T$dx9qU%y@F%1;4bT2EBxt8swPF zP^!nsRfJTB)-F#a!x&vg!j95fKA+HNtf93alsnpLr4l?=r2?PHp(@FSczYZb5O+LO z8>D!C4iqArmWrWT8L4mQ06R9GlWt(T#2ve8p^_~@3(w?SiqItgbNn8qolk0&Cn(f< zURHcVo`|jDD6`R!LM9BnAVAMvl^Lh~A5L#Sn4WFG9+{>*TcCJ#4fxCiPg8wn$N?jG z+7Wm@lLK8e-fGFla^@6;*OuX@F`U+4^)aNoA%P*M6bcC-XF>`f-0#s&odjC+P4&151@G1c8j_aP1ODtR zyncvH_IjS0K;`}ld!_muP0)^SYI!r&Z#GcZX;FiAgieQVJb?z-!|3S(H(?stVi;x> zvyPd8e+%&sQR&mGe3ctUmP~(V3V4DN__1_tI=$)SrUQP!mJA)c-?KLZKsXGO+pz!I zyQ`SD3g8F5=~T@VZ?9tZ#=-gIQ}8mx?!SU-`Ur>|IWU;X9n--t6Y9hpp&J3L6HBK< zk-g*9X}m*KFc9kA(8X-d^mT|(sE_0j1aAN3blQU<7(M}@n*8N-a~t22n}%AE9_Kr!$Lq_0S>X0z-eE) zxWO2*WB&}k)Ta#YZTH<#>`i{WDodiVeC>wXdB@2a{hFCe5d#ltT}b3~Gy#uSJzkZT zmCYZFyjy%=3N-8gIU@+-Eqq6md#|WUyu-c^zMJvi4v*%kF*8YR=;@gGzJu9v<;p*f zXr5X)Q|CkcEQW+SNs?&R;-BIOqj~DVnW{iAkhfsOK%Vxgr)J6?Scxf+6!8jIC`hXd z9tF59dqKo0s*ZxKTE+a3vmiw(Nyp1z*c&PlCg);u-BLLr?Ne{gTyL>fII9!`@)@Ya zcSF=M8wQ&KGarl$uBeB{lj0FN8N1|q>h76sGjZEICC%b}F1uY(Xl)?}Zvy7cf+mlM z4|Kl+FyAa4Hh|4Ot;$`APS^5pjDVN=2;3A;HO=DG0sdn28F3c$A1~mxlEO~Htw#!@ z2>Yq{B96xe`e2c^T**Xu4ux`&3rnvch0#Ml%W&tufcu>s$umJk=#_^|n8?ZXJTvSu zr1$Z?0%=Vs-y+4&s+OW31BhfI&H6R7B)WanHO-$X-Cff=@c*`?jP_Zfj<3M;%D$;} z-oR%RrQwfW$Zh(JPVmm@+Gh*ulnS6Y2OH8nqLweNixn02EHPR0wbvyT;zGiJ7CJvUpbaJyY9t2d}F=+5+H-huzu>Cx;;n$0UEuf^5Ot(p59 zI4*!@=G{A+>4;o?yRT1uoptqXxTjw4=8p)-c=wHZyn1X{F}u<5@NC*CkI$ypj%cy5 zZ2f_Ot>Tk_#&d|p_wKp!R{Lxv7(W=n`2LSlKiyFIQ};in9b|VgjAV1Gar;+iU;apW zjMp@q-SzqGQKafq0{SyeeEsFlzJd48FU7F+Drr{@`duuw)WuRS!ldYW3S6Xz3fdFs zp#k-=zJZ8$GG~V{?;7#4+U_#5{);|~^d%nMQJ)*=V*S{C^c)670&N9H7!^)0Uu^{s zwhN($^rQw^n=cs&iyXBE9(vG3QkocXyf}fs)PYP>>uh4)M}j|m9H~xpll~5?r$;9) ziqz4wIPTBPZk?Tl*I44}&vD_%qrj|A)J1)78}IdOQl55Qo2HM&oxR-bpBr)W99CS{g=32&yl8GZD<)Fr2~c zdWy25NGe)pT3)k(lr0viJdG46kqoJ3)ljnI+(Y+}BIRX7*A3**D2Urvb4+on(xo$2 zg;1R66+>!KZ@u(AVuar?OrR*+)aJlQg zIU1b#ZF6oy^m}Cv&H0hgWy1ATaQCQC+I4u229~;QbDmT3Xs&58T17SY!W@l_LOUG1 zT7v_^AUz23%A7hy)}Z=M^4C*UY<8{&G;7-&^k`keb8`kN88cS{Bkn~}oU5W0&((mN zrY5Pm)u6P>5LEP_U3Ig0w*xOq<7vy(QA%8#dgy|7-9J|$Mi`IE7y9Q?{Of*cc`7|a zBr*QE^eD|m(LXmH3ORwfTVA(o>s-!ON#+%j0AdG`urXA5uK<#QI5!&)9g)oUZ7@F7 zdyh2EoV0^vgvq2AeK+BD|Nl?mEd!d)#cVZnXyGF=l%E6ruQ1UX>_{XQmL^BZB4$yy z>*!qG_46*!Oi~w?3Ag8>nqJ{Qx951Z(;$0dCkLNA{DoJ5oVmHN+Ypr(RI9#8RgZtuIH>7pKTcxPg+wCwgm)ovNE5~B&_kma8V6E@ zt48n8k`b09{#L2?LZbQ`CaJ#{2jGp^8z(~QpwJ1=456C(@d1~<43RLqTk$lBM82GA zjw9hkh~TG!)VVMla+*~5kS1!2`bZcM6r1QN7L^PxZ=(1Fb;N_3>cpdsJH!OyFpDH0C>kxRl$C; z_We+{56a?=b2=KGBCQb~fb3X27Y{Vgy*o{$`*?RA5e|Y~ z#5s*gBad*Jy4__x$~UPDRXw0^Um^!L>6kRqEDa!G5CmFLMRy08z3gCKH1#c8rQrglE1 zRaMOZ;XRQ+WxOyiQR$_4qSHPb!q{14Xmom@Vm0eB_8 zjE)GX;(|D7;{r96)t~xo-arJqMS9Fc(d#OUQ?%eC1+!?u>|`}{QLL+>paa!K`t4kL zHv&ghQS%XfECP3-(##(h#4P;0ag0))wv3uHW?`}d(KO{W6_u&!#3ncLbNg}Yo7@Yj zj!&AY)N0<{G{13-0%=&N)~3OsUxxi*M~+(SC(Rcchcq2-dT=38w;cQqVA`ATWRglr z8xJ>KYZ}sY6#w>NZ#~AVxb!kyOiRNr+LaA%ydP14YP?}{yD6us7yeW)EWCiS7w}*c zU0UQpsADAY!G&bvdqHV&ptYQ)i(+o0I;ys&m_;;>toa&1SMxdOEq$ji%1+QUZQ@j{ zwF{PV>e_Kk`XUv+9CY-}ouak=q`6_?o<%gI zflge#(}|u%J5dv93Y4zU@&0*N=G%D)GCMvB+N_@x)lKEUt59Y;h^ z-Km5@l#gooqf*m3?kxrLIDV-{wKf%d0E^n8T=i_9>y;Xcg65ot#?@^v*GXkeZJiPOS&BJzAK8WfBJ$ap!6tr~$#mUe&Li7X15GMJEsbZ{xfpzU!&#mirpRr6I@S(pIsS;;sDO zHWJMycy8m@C`VuO8;2;=e9Gd{_o^F_R$Ry2J6}B+v{Bny4&S>O)4(xb+)MYN`cyi2 zBHSWd6^4QWerOxoVav>tRA$7zWDVYpQPWg2xneBrAmN3cuOtXPX?dZMv>x|^#W3z3 z*=(~`ctJ8RMbIm>$_vrz+mIYXFRvPRKe2>Mgf5ue-RK%5`uFexoFruk7U@VItszY) z5qXk6W9iehd-Y;^OadN7^xtE6v+s?*J$?V%cd+k3-@ASL`UGYW^Z!+MwZBmmVSKN< zdtL8Z8cPvMRmzo8^l0goQiMWmr7cvj951#KJ{TnJRj$1=z1`W}yT%ug6d`Ji8UjYa zM9gVM4KWHNm_P!EA2_24#vo|0P_-#BR1&FC*Wa_#Yk~j3FEI1WYv*QXo_St=&q?Qm zbJ_vkr1X(fEKQLezNyjQqSvDz#v9^)#?<)K_z$sjxb|M_`K)KQdx^FuhzFVn z#pU09lK){m4}^1aA$Ib%M3zDuPpDfOwbi)Bgm(2tLR>{11qrMkLGX7#aGJmx-b`## ze~n+pwyDu5eFf=}@$^Mp20ryB#_h!abhZ%mKlql@)eX9MYc=Qut}af7C$W#G1I=h4 z(4dp-1n{!@?rz%CJEE^B#}kQIyRuHN0#qE8QA^reP5PNB+4e7}C-U?0P$(UB6`9ka zm!_>fabmrUlUndMjapnMiBhAsM<=caF@e&@`aEQa-&L#b-FCD4D_zoK-I=F%M`N?7 z&D``)dZ4*!P@kK2bP{U}L1jwU&ZVwFor*PM4!uM3jEeOA#%)e{&D(0UM6^bG7cP19 zM^TW1Ul3r!1}h0?SD;T4+R2SLDZ?t#4;XSwD`HAC8IzuHVw`A%P8Il9JhKlUC5`IY z)n)isu18S8))iIZ^=-c|eZA8^ArPp&wdhWs8_IS5hLIaaKoywy{4w*2b;UZ=<>8W~ zgn@lRcbJD?H2{AoE;J7xH2|cF+V0c7Dr>_0{6T~l2tlUI9YcQhkqt#m%i*(_3=o1M zmY>5PL~>0_5%cBnMM$u!!ke1)XHpjoy@;ua@(49C~I9P^Q%mQ;gpN@N|cbyN14)s*bT^)Rm)s4l@1u= zA=iPjLQ}2GW>HvbDgcRHjcH*P3s5$m!wi<0a@~ReN@`^Os3||>rqQI`^afpf9Q0U; z9-lJ3l@s}Dh4-22G6WZEsw!?}9oiF_P$tx<&G*pyD}1}DtZAu$FifmmJrfJ0@B`+A zLC`;AMVKW7351_mkBtey?! zj-mR9K_9Tn|1y;@j@GK;ayDWRi$c<*5re)cl^0oRSm4>TurV~qHVRpYdjx6eCUiqg z3>~}BP5Efz(Uh4la|3I+nt6&8r7POdvD;_E_XpbiA$^-bnbZlisl zT92QTmXeG!vRH=8ZTP#Ptl1`sDxLL$$sG=EWx{Sr50D51!BHSw_jpL^)}jt}l95M8 z0lgFkJIPF)(xcEM6GhY{+*TTI7zku1O+cg!1d7c%lSHEoB9g*^0C^g+vUz5cIUE%7 zo;*nUB>xGU_9F=~@nE-WG@8Ab)#Enhn{9fK(-xSHJBsAMuEgbQ#g~k`vgKMe-+jm4 zS^b{z>hw7AB^4+&X`pQFW-KN=W0VgtfNL)$xVHjrzg^|O<}A1O+k)$*S-Aod;*xxP zzO4d-nn15LwtWr(xCHD~Ndoa9>l?|x-~KU4_fLD0M*DO;tucb@^zmy+Xp<1L2iC&G zx)5tbFM$im%UGN{ySvxzPV!$!lGrla@y=U1-kHpH98BdB7_W*uqMMdk$dx(sWY323TydHinyjpk7n2c ll)AS^&7y@%LQ21zp7;mE#i8Qch#)Nr&A*K_QT>0D_z#*do}&N& literal 0 HcmV?d00001 From 30577e05d43d34a97f9282435098285460087a77 Mon Sep 17 00:00:00 2001 From: Carsten Strotmann Date: Wed, 21 Apr 2021 20:35:29 +0200 Subject: [PATCH 17/21] new "vlist" inspired by F79Forth --- 8086/msdos/source.img | 1 - 8086/pc-baremetal/vlist.fth | 18 ++++++++++++++++++ 2 files changed, 18 insertions(+), 1 deletion(-) delete mode 100644 8086/msdos/source.img create mode 100644 8086/pc-baremetal/vlist.fth diff --git a/8086/msdos/source.img b/8086/msdos/source.img deleted file mode 100644 index 2a09adf..0000000 --- a/8086/msdos/source.img +++ /dev/null @@ -1 +0,0 @@ - \ No newline at end of file diff --git a/8086/pc-baremetal/vlist.fth b/8086/pc-baremetal/vlist.fth new file mode 100644 index 0000000..dc1ad72 --- /dev/null +++ b/8086/pc-baremetal/vlist.fth @@ -0,0 +1,18 @@ +: .flags ( cntf -- ) + dup $80 and if [char] R emit else space then + dup $40 and if [char] I emit else space then + $20 and if [char] N emit else space then ; + +: vlist ( -- ) base @ cr + ." Word" &25 spaces ." Flags CFA Length" cr + [compile] char capital >r context @ + BEGIN @ dup stop? 0= and + WHILE ?cr dup 2+ r@ bl = over 1+ c@ r@ = or + IF dup .name + dup c@ $F and &20 swap - spaces ( Name ) + dup c@ .flags space ( Count Field ) + dup name> hex u. space ( CFA ) + 2- 2- @ decimal 3 u.r space ( Block ) + cr + ELSE drop THEN + REPEAT drop rdrop base ! ; From 3c1b33c68f316a4210331e7e2d74c1a1caf421df Mon Sep 17 00:00:00 2001 From: Carsten Strotmann Date: Mon, 26 Apr 2021 23:27:52 +0200 Subject: [PATCH 18/21] Target Glossary F2012 A-C --- doc/Target-Glossary.org | 862 ++++++++++++++++++++-------------------- 1 file changed, 438 insertions(+), 424 deletions(-) diff --git a/doc/Target-Glossary.org b/doc/Target-Glossary.org index 5120139..fef7fbf 100644 --- a/doc/Target-Glossary.org +++ b/doc/Target-Glossary.org @@ -4,427 +4,441 @@ Comparison of user visible words in each target base kernel image - | Word | C64/C16 | CP/M | MS-DOS | Atari ST | Atari 8bit | Apple 1/2 | PET | py65 | | - |---------------+---------+------+--------+----------+------------+-----------+-----+------+---| - | ASSEMBLER | core | | | | | | | core | | - | FORTH-83 | core | | | | | | | core | | - | (R/W | | | | | | | | core | | - | DRVINIT | core | | | | | | | core | | - | DRV? | core | | | | | | | core | | - | >DRIVE | core | | | | | | | core | | - | DRIVE | core | | | | | | | core | | - | BLK/DRV | core | | | | | | | core | | - | B/BLK | core | | | | | | | core | | - | DISPLAY | core | | | | | | | core | | - | KEYBOARD | core | | | | | | | core | | - | 65TYPE | | | | | | | | | | - | 65AT? | | | | | | | | | | - | 65AT | | | | | | | | | | - | 65PAGE | | | | | | | | | | - | 65DEL | | | | | | | | | | - | 65CR | | | | | | | | | | - | 65EMIT | | | | | | | | | | - | (EMIT | | | | | | | | | | - | 65EXPECT | | | | | | | | | | - | 65DECODE | | | | | | | | | | - | #LF | | | | | | | | core | | - | #ESC | | | | | | | | core | | - | #CR | core | | | | | | | core | | - | #BS | core | | | | | | | core | | - | 65KEY | | | | | | | | | | - | CUROFF | core | | | | | | | core | | - | CURON | core | | | | | | | core | | - | GETKEY | core | | | | | | | core | | - | 65KEY? | | | | | | | | | | - | RESTART | core | | | | | | | core | | - | COLD | core | | | | | | | core | | - | 'RESTART | core | | | | | | | core | | - | 'COLD | core | | | | | | | core | | - | EXPECT | core | | | | | | | core | | - | DECODE | core | | | | | | | core | | - | KEY? | core | | | | | | | core | | - | KEY | core | | | | | | | core | | - | INPUT: | core | | | | | | | core | | - | COL | core | | | | | | | core | | - | ROW | core | | | | | | | core | | - | AT? | core | | | | | | | core | | - | AT | core | | | | | | | core | | - | PAGE | core | | | | | | | core | | - | DEL | core | | | | | | | core | | - | TYPE | core | | | | | | | core | | - | CR | core | | | | | | | core | | - | EMIT | core | | | | | | | core | | - | OUTPUT: | core | | | | | | | core | | - | ?CR | core | | | | | | | core | | - | STOP? | core | | | | | | | core | | - | BYE | core | | | | | | | core | | - | SAVE | core | | | | | | | core | | - | EMPTY | core | | | | | | | core | | - | FORGET | core | | | | | | | core | | - | (FORGET | core | | | | | | | core | | - | CLEAR | core | | | | | | | core | | - | ALL-BUFFERS | core | | | | | | | core | | - | FREEBUFFER | core | | | | | | | core | | - | ALLOTBUFFER | core | | | | | | | core | | - | FIRST | core | | | | | | | core | | - | LIMIT | core | | | | | | | core | | - | CONVEY | core | | | | | | | core | | - | COPY | core | | | | | | | core | | - | BLKMOVE | core | | | | | | | | | - | (COPY | core | | | | | | | | | - | FLUSH | core | | | | | | | core | | - | EMPTY-BUFFERS | core | | | | | | | core | | - | SAVE-BUFFERS | core | | | | | | | core | | - | UPDATE | core | | | | | | | core | | - | BLOCK | core | | | | | | | core | | - | BUFFER | core | | | | | | | core | | - | (BLOCK | core | | | | | | | core | | - | (BUFFER | core | | | | | | | core | | - | CORE? | core | | | | | | | core | | - | R/W | core | | | | | | | core | | - | DISKERR | core | | | | | | | core | | - | (DISKERR | core | | | | | | | core | | - | B/BUF | core | | | | | | | core | | - | BUFFERS | core | | | | | | | | | - | PREV | core | | | | | | | core | | - | FILE | core | | | | | | | core | | - | UNLOCK | core | | | | | | | core | | - | LOCK | core | | | | | | | core | | - | PAUSE | core | | | | | | | core | | - | LIST | core | | | | | | | core | | - | L/S | core | | | | | | | core | | - | C/L | core | | | | | | | core | | - | .S | core | | | | | | | core | | - | U. | core | | | | | | | core | | - | . | core | | | | | | | core | | - | D. | core | | | | | | | core | | - | U.R | core | | | | | | | core | | - | .R | core | | | | | | | core | | - | D.R | core | | | | | | | core | | - | #S | core | | | | | | | core | | - | # | core | | | | | | | core | | - | SIGN | core | | | | | | | core | | - | #> | core | | | | | | | core | | - | <# | core | | | | | | | core | | - | HOLD | core | | | | | | | core | | - | SPACES | core | | | | | | | core | | - | SPACE | core | | | | | | | core | | - | -TRAILING | core | | | | | | | core | | - | BL | core | | | | | | | core | | - | ERROR" | core | | | | | | | core | | - | ABORT" | core | | | | | | | core | | - | (ABORT" | core | | | | | | | core | | - | (ERROR | core | | | | | | | core | | - | R# | core | | | | | | | core | | - | SCR | core | | | | | | | core | | - | ABORT | core | | | | | | | core | | - | 'ABORT | core | | | | | | | core | | - | STANDARDI/O | core | | | | | | | core | | - | QUIT | core | | | | | | | core | | - | 'QUIT | core | | | | | | | core | | - | (QUIT | core | | | | | | | core | | - | DEPTH | core | | | | | | | core | | - | RDEPTH | core | | | | | | | core | | - | --> | core | | | | | | | core | | - | +THRU | core | | | | | | | core | | - | THRU | core | | | | | | | core | | - | +LOAD | core | | | | | | | core | | - | LOAD | core | | | | | | | core | | - | PUSH | core | | | | | | | core | | - | .STATUS | core | | | | | | | core | | - | ?STACK | core | | | | | | | core | | - | IS | core | | | | | | | core | | - | (IS | core | | | | | | | core | | - | DEFER | core | | | | | | | core | | - | ] | core | | | | | | | core | | - | [ | core | | | | | | | core | | - | INTERPRET | core | | | | | | | core | | - | NO.EXTENSIONS | core | | | | | | | core | | - | NOTFOUND | core | | | | | | | core | | - | >INTERPRET | core | | | | | | | core | | - | NULLSTRING? | core | | | | | | | core | | - | ['] | core | | | | | | | core | | - | [COMPILE] | core | | | | | | | core | | - | ' | core | | | | | | | core | | - | FIND | core | | | | | | | core | | - | (FIND | core | | | | | | | core | | - | WORDS | core | | | | | | | core | | - | ORDER | core | | | | | | | core | | - | DEFINITIONS | core | | | | | | | core | | - | ONLYFORTH | core | | | | | | | core | | - | ONLY | core | | | | | | | core | | - | FORTH | core | | | | | | | core | | - | VOCABULARY | core | | | | | | | core | | - | TOSS | core | | | | | | | core | | - | ALSO | core | | | | | | | core | | - | CONTEXT | core | | | | | | | core | | - | CURRENT | core | | | | | | | core | | - | VP | core | | | | | | | core | | - | ALIAS | core | | | | | | | core | | - | USER | core | | | | | | | core | | - | UALLOT | core | | | | | | | core | | - | VARIABLE | core | | | | | | | core | | - | CONSTANT | core | | | | | | | core | | - | ; | core | | | | | | | core | | - | : | core | | | | | | | core | | - | CREATE: | core | | | | | | | | | - | .NAME | core | | | | | | | core | | - | >BODY | core | | | | | | | core | | - | NAME> | core | | | | | | | core | | - | >NAME | core | | | | | | | core | | - | NFA? | core | | | | | | | | | - | CREATE | core | | | | | | | core | | - | WARNING | core | | | | | | | core | | - | \vert | core | | | | | | | core | | - | ?HEAD | core | | | | | | | core | | - | DOES> | core | | | | | | | core | | - | HEAP? | core | | | | | | | core | | - | HEAP | core | | | | | | | core | | - | HALLOT | core | | | | | | | core | | - | CLEARSTACK | core | | | | | | | core | | - | RESTRICT | core | | | | | | | core | | - | IMMEDIATE | core | | | | | | | core | | - | RECURSIVE | core | | | | | | | core | | - | REVEAL | core | | | | | | | core | | - | HIDE | core | | | | | | | core | | - | LAST | core | | | | | | | core | | - | NUMBER | core | | | | | | | core | | - | 'NUMBER? | core | | | | | | | | | - | NUMBER? | core | | | | | | | core | | - | DPL | core | | | | | | | core | | - | PREVIOUS | core | | | | | | | | | - | CHAR | core | | | | | | | | | - | END? | core | | | | | | | | | - | CONVERT | core | | | | | | | core | | - | ACCUMULATE | core | | | | | | | core | | - | DIGIT? | core | | | | | | | core | | - | DECIMAL | core | | | | | | | core | | - | HEX | core | | | | | | | core | | - | \NEEDS | core | | | | | | | core | | - | \\ | core | | | | | | | core | | - | \ | core | | | | | | | core | | - | .( | core | | | | | | | core | | - | ( | core | | | | | | | core | | - | ." | core | | | | | | | core | | - | (." | core | | | | | | | core | | - | " | core | | | | | | | core | | - | (" | core | | | | | | | core | | - | "LIT | core | | | | | | | core | | - | ," | core | | | | | | | core | | - | ASCII | core | | | | | | | core | | - | STATE | core | | | | | | | core | | - | NAME | core | | | | | | | core | | - | PARSE | core | | | | | | | core | | - | WORD | core | | | | | | | core | | - | SOURCE | core | | | | | | | core | | - | CAPITALIZE | core | | | | | | | core | | - | CAPITAL | core | | | | | | | core | | - | /STRING | core | | | | | | | core | | - | SKIP | core | | | | | | | core | | - | SCAN | core | | | | | | | core | | - | QUERY | core | | | | | | | core | | - | TIB | core | | | | | | | core | | - | SPAN | core | | | | | | | core | | - | BLK | core | | | | | | | core | | - | >IN | core | | | | | | | core | | - | >TIB | core | | | | | | | core | | - | #TIB | core | | | | | | | core | | - | COMPILE | core | | | | | | | core | | - | C, | core | | | | | | | core | | - | , | core | | | | | | | core | | - | ALLOT | core | | | | | | | core | | - | PAD | core | | | | | | | core | | - | HERE | core | | | | | | | core | | - | FILL | core | | | | | | | core | | - | ERASE | core | | | | | | | core | | - | COUNT | core | | | | | | | core | | - | PLACE | core | | | | | | | core | | - | MOVE | core | | | | | | | core | | - | CMOVE> | core | | | | | | | core | | - | CMOVE | core | | | | | | | core | | - | UD/MOD | core | | | | | | | core | | - | U/MOD | core | | | | | | | core | | - | */ | core | | | | | | | core | | - | */MOD | core | | | | | | | core | | - | MOD | core | | | | | | | core | | - | / | core | | | | | | | core | | - | /MOD | core | | | | | | | core | | - | 2/ | core | | | | | | | core | | - | M/MOD | core | | | | | | | core | | - | UM/MOD | core | | | | | | | core | | - | 2* | core | | | | | | | core | | - | * | core | | | | | | | core | | - | M* | core | | | | | | | core | | - | UM* | core | | | | | | | core | | - | UNLOOP | core | | | | | | | | | - | LEAVE | core | | | | | | | core | | - | +LOOP | core | | | | | | | core | | - | LOOP | core | | | | | | | core | | - | ?DO | core | | | | | | | core | | - | DO | core | | | | | | | core | | - | UNTIL | core | | | | | | | core | | - | REPEAT | core | | | | | | | core | | - | WHILE | core | | | | | | | core | | - | BEGIN | core | | | | | | | core | | - | ELSE | core | | | | | | | core | | - | THEN | core | | | | | | | core | | - | IF | core | | | | | | | core | | - | CASE? | core | | | | | | | core | | - | ?PAIRS | core | | | | | | | core | | - | RESOLVE | core | | | | | | | core | | - | >MARK | core | | | | | | | core | | - | ?BRANCH | core | | | | | | | core | | - | BRANCH | core | | | | | | | core | | - | J | core | | | | | | | core | | - | I | core | | | | | | | core | | - | (+LOOP | core | | | | | | | core | | - | (LOOP | core | | | | | | | core | | - | ENDLOOP | core | | | | | | | core | | - | BOUNDS | core | | | | | | | core | | - | (?DO | core | | | | | | | core | | - | (DO | core | | | | | | | core | | - | ABS | core | | | | | | | core | | - | DBAS | core | | | | | | | core | | - | EXTEND | core | | | | | | | core | | - | UMIN | core | | | | | | | core | | - | UMAX | core | | | | | | | core | | - | MAX | core | | | | | | | core | | - | MIN | core | | | | | | | core | | - | D< | core | | | | | | | core | | - | D= | core | | | | | | | core | | - | D0= | core | | | | | | | core | | - | = | core | | | | | | | core | | - | U> | core | | | | | | | core | | - | 0<> | core | | | | | | | core | | - | 0> | core | | | | | | | core | | - | > | core | | | | | | | core | | - | U< | core | | | | | | | core | | - | < | core | | | | | | | core | | - | UWITHIN | core | | | | | | | core | | - | 0= | core | | | | | | | core | | - | 0< | core | | | | | | | core | | - | LITERAL | core | | | | | | | core | | - | LIT | core | | | | | | | core | | - | CLIT | core | | | | | | | core | | - | OFF | core | | | | | | | core | | - | ON | core | | | | | | | core | | - | 4 | core | | | | | | | core | | - | 3 | core | | | | | | | core | | - | 2 | core | | | | | | | core | | - | 1 | core | | | | | | | core | | - | 0 | core | | | | | | | core | | - | -1 | core | | | | | | | core | | - | FALSE | core | | | | | | | core | | - | TRUE | core | | | | | | | core | | - | 2- | core | | | | | | | core | | - | 1- | core | | | | | | | core | | - | 4+ | core | | | | | | | | | - | 3+ | core | | | | | | | core | | - | 2+ | core | | | | | | | core | | - | 1+ | core | | | | | | | core | | - | D+ | core | | | | | | | core | | - | DNEGATE | core | | | | | | | core | | - | NEGATE | core | | | | | | | core | | - | NOT | core | | | | | | | core | | - | - | core | | | | | | | core | | - | XOR | core | | | | | | | core | | - | AND | core | | | | | | | core | | - | OR | core | | | | | | | core | | - | + | core | | | | | | | core | | - | 2DUP | core | | | | | | | core | | - | 2DROP | core | | | | | | | core | | - | 2SWAP | core | | | | | | | core | | - | ROLL | core | | | | | | | core | | - | PICK | core | | | | | | | core | | - | UNDER | core | | | | | | | core | | - | NIP | core | | | | | | | core | | - | ROT | core | | | | | | | core | | - | -ROT | core | | | | | | | core | | - | OVER | core | | | | | | | core | | - | ?DUP | core | | | | | | | core | | - | DUP | core | | | | | | | core | | - | SWAP | core | | | | | | | core | | - | DROP | core | | | | | | | core | | - | +! | core | | | | | | | core | | - | ! | core | | | | | | | core | | - | @ | core | | | | | | | core | | - | CTOGGLE | core | | | | | | | core | | - | C! | core | | | | | | | core | | - | C@ | core | | | | | | | core | | - | PERFORM | core | | | | | | | core | | - | EXECUTE | core | | | | | | | core | | - | ?EXIT | core | | | | | | | core | | - | UNNEST | core | | | | | | | | | - | EXIT | core | | | | | | | core | | - | RDROP | core | | | | | | | core | | - | R@ | core | | | | | | | core | | - | R> | core | | | | | | | core | | - | >R | core | | | | | | | core | | - | RP! | core | | | | | | | core | | - | RP@ | core | | | | | | | core | | - | UP! | core | | | | | | | core | | - | UP@ | core | | | | | | | core | | - | SP! | core | | | | | | | core | | - | SP@ | core | | | | | | | core | | - | UDP | core | | | | | | | core | | - | VOC-LINK | core | | | | | | | core | | - | ERRORHANDLER | core | | | | | | | core | | - | INPUT | core | | | | | | | core | | - | OUTPUT | core | | | | | | | core | | - | BASE | core | | | | | | | core | | - | OFFSET | core | | | | | | | core | | - | DP | core | | | | | | | core | | - | R0 | core | | | | | | | core | | - | S0 | core | | | | | | | core | | - | ORIGIN | core | | | | | | | core | | - | NOOP | core | | | | | | | core | | - | RECOVER | core | | | | | | | core | | - | END-TRACE | core | | | | | | | core | | - | LOGO | core | | | | | | | | | - | (64 | core | | | | | | | | | - | C) | core | | | | | | | | | - | (16 | core | | | | | | | | | - | C64INIT | core | | | | | | | | | - | INIT-SYSTEM | core | | | | | | | | | - | INK-POT | core | | | | | | | | | - | FINDEX | core | | | | | | | | | - | INDEX | core | | | | | | | | | - | 1541RW | core | | | | | | | | | - | DISKCLOSE | core | | | | | | | | | - | DISKOPEN | core | | | | | | | | | - | WRITESECTOR | core | | | | | | | | | - | READSECTOR | core | | | | | | | | | - | DERROR? | core | | | | | | | | | - | I/O-STATUS? | core | | | | | | | | | - | BUSINPUT | core | | | | | | | | | - | BUS@ | core | | | | | | | | | - | BUSTYPE | core | | | | | | | | | - | BUS! | core | | | | | | | | | - | BUSIN | core | | | | | | | | | - | (BUSIN | core | | | | | | | | | - | BUSCLOSE | core | | | | | | | | | - | BUSOPEN | core | | | | | | | | | - | BUSOUT | core | | | | | | | | | - | (BUSOUT | core | | | | | | | | | - | ?DEVICE | core | | | | | | | | | - | (?DEVICE | core | | | | | | | | | - | BUSOFF | core | | | | | | | | | - | I/O | core | | | | | | | | | - | (DRV | core | | | | | | | | | - | C64TYPE | core | | | | | | | | | - | C64AT? | core | | | | | | | | | - | C64AT | core | | | | | | | | | - | C64PAGE | core | | | | | | | | | - | C64DEL | core | | | | | | | | | - | C64CR | core | | | | | | | | | - | C64EMIT | core | | | | | | | | | - | PRINTABLE | core | | | | | | | | | - | CON! | core | | | | | | | | | - | C64EXPECT | core | | | | | | | | | - | C64DECODE | core | | | | | | | | | - | C64KEY | core | | | | | | | | | - | C64KEY? | core | | | | | | | | | - | CUSTOM-REMOVE | core | | | | | | | | | - | | | | | | | | | | | + | Word | C64/C16 | CP/M | MS-DOS | Atari ST | Atari 8bit | Apple 1/2 | PET | py65 | 8086bm | Forth2012 | + |---------------+---------+------+--------+----------+------------+-----------+-----+------+--------+-----------| + | ASSEMBLER | core | | | | | | | core | | | + | FORTH-83 | core | | | | | | | core | | | + | (R/W | | | | | | | | core | | | + | DRVINIT | core | | | | | | | core | | | + | DRV? | core | | | | | | | core | | | + | >DRIVE | core | | | | | | | core | | | + | DRIVE | core | | | | | | | core | | | + | BLK/DRV | core | | | | | | | core | | | + | B/BLK | core | | | | | | | core | | | + | DISPLAY | core | | | | | | | core | | | + | KEYBOARD | core | | | | | | | core | | | + | 65TYPE | | | | | | | | | | | + | 65AT? | | | | | | | | | | | + | 65AT | | | | | | | | | | | + | 65PAGE | | | | | | | | | | | + | 65DEL | | | | | | | | | | | + | 65CR | | | | | | | | | | | + | 65EMIT | | | | | | | | | | | + | (EMIT | | | | | | | | | | | + | 65EXPECT | | | | | | | | | | | + | 65DECODE | | | | | | | | | | | + | #LF | | | | | | | | core | | | + | #ESC | | | | | | | | core | | | + | #CR | core | | | | | | | core | | | + | #BS | core | | | | | | | core | | | + | 65KEY | | | | | | | | | | | + | CUROFF | core | | | | | | | core | | | + | CURON | core | | | | | | | core | | | + | GETKEY | core | | | | | | | core | | | + | 65KEY? | | | | | | | | | | | + | RESTART | core | | | | | | | core | | | + | COLD | core | | | | | | | core | | | + | 'RESTART | core | | | | | | | core | | | + | 'COLD | core | | | | | | | core | | | + | EXPECT | core | | | | | | | core | | | + | DECODE | core | | | | | | | core | | | + | KEY? | core | | | | | | | core | | | + | KEY | core | | | | | | | core | | | + | INPUT: | core | | | | | | | core | | | + | COL | core | | | | | | | core | | | + | ROW | core | | | | | | | core | | | + | AT? | core | | | | | | | core | | | + | AT | core | | | | | | | core | | | + | PAGE | core | | | | | | | core | | | + | DEL | core | | | | | | | core | | | + | TYPE | core | | | | | | | core | | | + | CR | core | | | | | | | core | | core | + | EMIT | core | | | | | | | core | | | + | OUTPUT: | core | | | | | | | core | | | + | ?CR | core | | | | | | | core | | | + | STOP? | core | | | | | | | core | | | + | BYE | core | | | | | | | core | | | + | SAVE | core | | | | | | | core | | | + | EMPTY | core | | | | | | | core | | | + | FORGET | core | | | | | | | core | | | + | (FORGET | core | | | | | | | core | | | + | CLEAR | core | | | | | | | core | | | + | ALL-BUFFERS | core | | | | | | | core | | | + | FREEBUFFER | core | | | | | | | core | | | + | ALLOTBUFFER | core | | | | | | | core | | | + | FIRST | core | | | | | | | core | | | + | LIMIT | core | | | | | | | core | | | + | CONVEY | core | | | | | | | core | | | + | COPY | core | | | | | | | core | | | + | BLKMOVE | core | | | | | | | | | | + | (COPY | core | | | | | | | | | | + | FLUSH | core | | | | | | | core | | | + | EMPTY-BUFFERS | core | | | | | | | core | | | + | SAVE-BUFFERS | core | | | | | | | core | | | + | UPDATE | core | | | | | | | core | | | + | BLOCK | core | | | | | | | core | | | + | BUFFER | core | | | | | | | core | | | + | (BLOCK | core | | | | | | | core | | | + | (BUFFER | core | | | | | | | core | | | + | CORE? | core | | | | | | | core | | | + | R/W | core | | | | | | | core | | | + | DISKERR | core | | | | | | | core | | | + | (DISKERR | core | | | | | | | core | | | + | B/BUF | core | | | | | | | core | | | + | BUFFERS | core | | | | | | | | | | + | PREV | core | | | | | | | core | | | + | FILE | core | | | | | | | core | | | + | UNLOCK | core | | | | | | | core | | | + | LOCK | core | | | | | | | core | | | + | PAUSE | core | | | | | | | core | | | + | LIST | core | | | | | | | core | | | + | L/S | core | | | | | | | core | | | + | C/L | core | | | | | | | core | | | + | .S | core | | | | | | | core | | | + | U. | core | | | | | | | core | | | + | . | core | | | | | | | core | | | + | D. | core | | | | | | | core | | | + | U.R | core | | | | | | | core | | | + | .R | core | | | | | | | core | | | + | D.R | core | | | | | | | core | | | + | #S | core | | | | | | | core | | | + | # | core | | | | | | | core | | | + | SIGN | core | | | | | | | core | | | + | #> | core | | | | | | | core | | | + | <# | core | | | | | | | core | | | + | HOLD | core | | | | | | | core | | | + | SPACES | core | | | | | | | core | | | + | SPACE | core | | | | | | | core | | | + | -TRAILING | core | | | | | | | core | | | + | BL | core | | | | | | | core | | core | + | ERROR" | core | | | | | | | core | | | + | ABORT" | core | | | | | | | core | | core | + | (ABORT" | core | | | | | | | core | | | + | (ERROR | core | | | | | | | core | | | + | R# | core | | | | | | | core | | | + | SCR | core | | | | | | | core | | | + | ABORT | core | | | | | | | core | | core | + | 'ABORT | core | | | | | | | core | | | + | STANDARDI/O | core | | | | | | | core | | | + | QUIT | core | | | | | | | core | | | + | 'QUIT | core | | | | | | | core | | | + | (QUIT | core | | | | | | | core | | | + | DEPTH | core | | | | | | | core | | | + | RDEPTH | core | | | | | | | core | | | + | --> | core | | | | | | | core | | | + | +THRU | core | | | | | | | core | | | + | THRU | core | | | | | | | core | | | + | +LOAD | core | | | | | | | core | | | + | LOAD | core | | | | | | | core | | | + | PUSH | core | | | | | | | core | | | + | .STATUS | core | | | | | | | core | | | + | ?STACK | core | | | | | | | core | | | + | IS | core | | | | | | | core | | | + | (IS | core | | | | | | | core | | | + | DEFER | core | | | | | | | core | | | + | ] | core | | | | | | | core | | | + | [ | core | | | | | | | core | | core | + | INTERPRET | core | | | | | | | core | | | + | NO.EXTENSIONS | core | | | | | | | core | | | + | NOTFOUND | core | | | | | | | core | | | + | >INTERPRET | core | | | | | | | core | | | + | NULLSTRING? | core | | | | | | | core | | | + | ['] | core | | | | | | | core | | core | + | [COMPILE] | core | | | | | | | core | | core | + | ' | core | | | | | | | core | | | + | FIND | core | | | | | | | core | | | + | (FIND | core | | | | | | | core | | | + | WORDS | core | | | | | | | core | | | + | ORDER | core | | | | | | | core | | | + | DEFINITIONS | core | | | | | | | core | | | + | ONLYFORTH | core | | | | | | | core | | | + | ONLY | core | | | | | | | core | | | + | FORTH | core | | | | | | | core | | | + | VOCABULARY | core | | | | | | | core | | | + | TOSS | core | | | | | | | core | | | + | ALSO | core | | | | | | | core | | | + | CONTEXT | core | | | | | | | core | | | + | CURRENT | core | | | | | | | core | | | + | VP | core | | | | | | | core | | | + | ALIAS | core | | | | | | | core | | | + | USER | core | | | | | | | core | | | + | UALLOT | core | | | | | | | core | | | + | VARIABLE | core | | | | | | | core | | | + | CONSTANT | core | | | | | | | core | | core | + | ; | core | | | | | | | core | | | + | : | core | | | | | | | core | | | + | CREATE: | core | | | | | | | | | | + | .NAME | core | | | | | | | core | | | + | >BODY | core | | | | | | | core | | | + | NAME> | core | | | | | | | core | | | + | >NAME | core | | | | | | | core | | | + | NFA? | core | | | | | | | | | | + | CREATE | core | | | | | | | core | | core | + | WARNING | core | | | | | | | core | | | + | \vert | core | | | | | | | core | | | + | ?HEAD | core | | | | | | | core | | | + | DOES> | core | | | | | | | core | | | + | HEAP? | core | | | | | | | core | | | + | HEAP | core | | | | | | | core | | | + | HALLOT | core | | | | | | | core | | | + | CLEARSTACK | core | | | | | | | core | | | + | RESTRICT | core | | | | | | | core | | | + | IMMEDIATE | core | | | | | | | core | | | + | RECURSIVE | core | | | | | | | core | | | + | REVEAL | core | | | | | | | core | | | + | HIDE | core | | | | | | | core | | | + | LAST | core | | | | | | | core | | | + | NUMBER | core | | | | | | | core | | | + | 'NUMBER? | core | | | | | | | | | | + | NUMBER? | core | | | | | | | core | | | + | DPL | core | | | | | | | core | | | + | PREVIOUS | core | | | | | | | | | | + | CHAR | core | | | | | | | | | | + | END? | core | | | | | | | | | | + | CONVERT | core | | | | | | | core | | | + | ACCUMULATE | core | | | | | | | core | | | + | DIGIT? | core | | | | | | | core | | | + | DECIMAL | core | | | | | | | core | | | + | HEX | core | | | | | | | core | | | + | \NEEDS | core | | | | | | | core | | | + | \\ | core | | | | | | | core | | | + | \ | core | | | | | | | core | | | + | .( | core | | | | | | | core | | | + | ( | core | | | | | | | core | | | + | ." | core | | | | | | | core | | | + | (." | core | | | | | | | core | | | + | " | core | | | | | | | core | | | + | (" | core | | | | | | | core | | | + | "LIT | core | | | | | | | core | | | + | ," | core | | | | | | | core | | | + | ASCII | core | | | | | | | core | | | + | STATE | core | | | | | | | core | | | + | NAME | core | | | | | | | core | | | + | PARSE | core | | | | | | | core | | | + | WORD | core | | | | | | | core | | | + | SOURCE | core | | | | | | | core | | | + | CAPITALIZE | core | | | | | | | core | | | + | CAPITAL | core | | | | | | | core | | | + | /STRING | core | | | | | | | core | | | + | SKIP | core | | | | | | | core | | | + | SCAN | core | | | | | | | core | | | + | QUERY | core | | | | | | | core | | | + | TIB | core | | | | | | | core | | | + | SPAN | core | | | | | | | core | | | + | BLK | core | | | | | | | core | | | + | >IN | core | | | | | | | core | | | + | >TIB | core | | | | | | | core | | | + | #TIB | core | | | | | | | core | | | + | COMPILE | core | | | | | | | core | | | + | C, | core | | | | | | | core | | core | + | , | core | | | | | | | core | | | + | ALLOT | core | | | | | | | core | | core | + | PAD | core | | | | | | | core | | | + | HERE | core | | | | | | | core | | | + | FILL | core | | | | | | | core | | | + | ERASE | core | | | | | | | core | | | + | COUNT | core | | | | | | | core | | core | + | PLACE | core | | | | | | | core | | | + | MOVE | core | | | | | | | core | | | + | CMOVE> | core | | | | | | | core | | | + | CMOVE | core | | | | | | | core | | | + | UD/MOD | core | | | | | | | core | | | + | U/MOD | core | | | | | | | core | | | + | */ | core | | | | | | | core | | | + | */MOD | core | | | | | | | core | | | + | MOD | core | | | | | | | core | | | + | / | core | | | | | | | core | | | + | /MOD | core | | | | | | | core | | | + | 2/ | core | | | | | | | core | | | + | M/MOD | core | | | | | | | core | | | + | UM/MOD | core | | | | | | | core | | | + | 2* | core | | | | | | | core | | | + | * | core | | | | | | | core | | | + | M* | core | | | | | | | core | | | + | UM* | core | | | | | | | core | | | + | UNLOOP | core | | | | | | | | | | + | LEAVE | core | | | | | | | core | | | + | +LOOP | core | | | | | | | core | | | + | LOOP | core | | | | | | | core | | | + | ?DO | core | | | | | | | core | | | + | DO | core | | | | | | | core | | | + | UNTIL | core | | | | | | | core | | | + | REPEAT | core | | | | | | | core | | | + | WHILE | core | | | | | | | core | | | + | BEGIN | core | | | | | | | core | | core | + | ELSE | core | | | | | | | core | | | + | THEN | core | | | | | | | core | | | + | IF | core | | | | | | | core | | | + | CASE? | core | | | | | | | core | | | + | ?PAIRS | core | | | | | | | core | | | + | RESOLVE | core | | | | | | | core | | | + | >MARK | core | | | | | | | core | | | + | ?BRANCH | core | | | | | | | core | | | + | BRANCH | core | | | | | | | core | | | + | J | core | | | | | | | core | | | + | I | core | | | | | | | core | | | + | (+LOOP | core | | | | | | | core | | | + | (LOOP | core | | | | | | | core | | | + | ENDLOOP | core | | | | | | | core | | | + | BOUNDS | core | | | | | | | core | | | + | (?DO | core | | | | | | | core | | | + | (DO | core | | | | | | | core | | | + | ABS | core | | | | | | | core | | core | + | DBAS | core | | | | | | | core | | | + | EXTEND | core | | | | | | | core | | | + | UMIN | core | | | | | | | core | | | + | UMAX | core | | | | | | | core | | | + | MAX | core | | | | | | | core | | | + | MIN | core | | | | | | | core | | | + | D< | core | | | | | | | core | | | + | D= | core | | | | | | | core | | | + | D0= | core | | | | | | | core | | | + | = | core | | | | | | | core | | | + | U> | core | | | | | | | core | | | + | 0<> | core | | | | | | | core | | | + | 0> | core | | | | | | | core | | | + | > | core | | | | | | | core | | | + | U< | core | | | | | | | core | | | + | < | core | | | | | | | core | | | + | UWITHIN | core | | | | | | | core | | | + | 0= | core | | | | | | | core | | | + | 0< | core | | | | | | | core | | | + | LITERAL | core | | | | | | | core | | | + | LIT | core | | | | | | | core | | | + | CLIT | core | | | | | | | core | | | + | OFF | core | | | | | | | core | | | + | ON | core | | | | | | | core | | | + | 4 | core | | | | | | | core | | | + | 3 | core | | | | | | | core | | | + | 2 | core | | | | | | | core | | | + | 1 | core | | | | | | | core | | | + | 0 | core | | | | | | | core | | | + | -1 | core | | | | | | | core | | | + | FALSE | core | | | | | | | core | | | + | TRUE | core | | | | | | | core | | | + | 2- | core | | | | | | | core | | | + | 1- | core | | | | | | | core | | | + | 4+ | core | | | | | | | | | | + | 3+ | core | | | | | | | core | | | + | 2+ | core | | | | | | | core | | | + | 1+ | core | | | | | | | core | | | + | D+ | core | | | | | | | core | | | + | DNEGATE | core | | | | | | | core | | | + | NEGATE | core | | | | | | | core | | | + | NOT | core | | | | | | | core | | | + | - | core | | | | | | | core | | | + | XOR | core | | | | | | | core | | | + | AND | core | | | | | | | core | | core | + | OR | core | | | | | | | core | | | + | + | core | | | | | | | core | | | + | 2DUP | core | | | | | | | core | | | + | 2DROP | core | | | | | | | core | | | + | 2SWAP | core | | | | | | | core | | | + | ROLL | core | | | | | | | core | | | + | PICK | core | | | | | | | core | | | + | UNDER | core | | | | | | | core | | | + | NIP | core | | | | | | | core | | | + | ROT | core | | | | | | | core | | | + | -ROT | core | | | | | | | core | | | + | OVER | core | | | | | | | core | | | + | ?DUP | core | | | | | | | core | | | + | DUP | core | | | | | | | core | | | + | SWAP | core | | | | | | | core | | | + | DROP | core | | | | | | | core | | | + | +! | core | | | | | | | core | | | + | ! | core | | | | | | | core | | | + | @ | core | | | | | | | core | | | + | CTOGGLE | core | | | | | | | core | | | + | C! | core | | | | | | | core | | core | + | C@ | core | | | | | | | core | | core | + | PERFORM | core | | | | | | | core | | | + | EXECUTE | core | | | | | | | core | | | + | ?EXIT | core | | | | | | | core | | | + | UNNEST | core | | | | | | | | | | + | EXIT | core | | | | | | | core | | | + | RDROP | core | | | | | | | core | | | + | R@ | core | | | | | | | core | | | + | R> | core | | | | | | | core | | | + | >R | core | | | | | | | core | | | + | RP! | core | | | | | | | core | | | + | RP@ | core | | | | | | | core | | | + | UP! | core | | | | | | | core | | | + | UP@ | core | | | | | | | core | | | + | SP! | core | | | | | | | core | | | + | SP@ | core | | | | | | | core | | | + | UDP | core | | | | | | | core | | | + | VOC-LINK | core | | | | | | | core | | | + | ERRORHANDLER | core | | | | | | | core | | | + | INPUT | core | | | | | | | core | | | + | OUTPUT | core | | | | | | | core | | | + | BASE | core | | | | | | | core | | core | + | OFFSET | core | | | | | | | core | | | + | DP | core | | | | | | | core | | | + | R0 | core | | | | | | | core | | | + | S0 | core | | | | | | | core | | | + | ORIGIN | core | | | | | | | core | | | + | NOOP | core | | | | | | | core | | | + | RECOVER | core | | | | | | | core | | | + | END-TRACE | core | | | | | | | core | | | + | LOGO | core | | | | | | | | | | + | (64 | core | | | | | | | | | | + | C) | core | | | | | | | | | | + | (16 | core | | | | | | | | | | + | C64INIT | core | | | | | | | | | | + | INIT-SYSTEM | core | | | | | | | | | | + | INK-POT | core | | | | | | | | | | + | FINDEX | core | | | | | | | | | | + | INDEX | core | | | | | | | | | | + | 1541RW | core | | | | | | | | | | + | DISKCLOSE | core | | | | | | | | | | + | DISKOPEN | core | | | | | | | | | | + | WRITESECTOR | core | | | | | | | | | | + | READSECTOR | core | | | | | | | | | | + | DERROR? | core | | | | | | | | | | + | I/O-STATUS? | core | | | | | | | | | | + | BUSINPUT | core | | | | | | | | | | + | BUS@ | core | | | | | | | | | | + | BUSTYPE | core | | | | | | | | | | + | BUS! | core | | | | | | | | | | + | BUSIN | core | | | | | | | | | | + | (BUSIN | core | | | | | | | | | | + | BUSCLOSE | core | | | | | | | | | | + | BUSOPEN | core | | | | | | | | | | + | BUSOUT | core | | | | | | | | | | + | (BUSOUT | core | | | | | | | | | | + | ?DEVICE | core | | | | | | | | | | + | (?DEVICE | core | | | | | | | | | | + | BUSOFF | core | | | | | | | | | | + | I/O | core | | | | | | | | | | + | (DRV | core | | | | | | | | | | + | C64TYPE | core | | | | | | | | | | + | C64AT? | core | | | | | | | | | | + | C64AT | core | | | | | | | | | | + | C64PAGE | core | | | | | | | | | | + | C64DEL | core | | | | | | | | | | + | C64CR | core | | | | | | | | | | + | C64EMIT | core | | | | | | | | | | + | PRINTABLE | core | | | | | | | | | | + | CON! | core | | | | | | | | | | + | C64EXPECT | core | | | | | | | | | | + | C64DECODE | core | | | | | | | | | | + | C64KEY | core | | | | | | | | | | + | C64KEY? | core | | | | | | | | | | + | CUSTOM-REMOVE | core | | | | | | | | | | + | ACCEPT | | | | | | | | | | core | + | ACTION-OF | | | | | | | | | | core | + | AGAIN | | | | | | | | | | core | + | ALIGN | | | | | | | | | | core | + | ALIGNED | | | | | | | | | | core | + | BUFFER: | | | | | | | | | | core | + | [char] | | | | | | | | | core | core | + | char | | | | | | | | | core | core | + | case | | | | | | | | | | core | + | CELL+ | | | | | | | | | | core | + | CELLS | | | | | | | | | | core | + | CHAR+ | | | | | | | | | | core | + | CHARS | | | | | | | | | | core | + | compile, | | | | | | | | | | core | + | | | | | | | | | | | | From 52d0ec8091ad73d381c9b6922ada94d30a48cea3 Mon Sep 17 00:00:00 2001 From: Carsten Strotmann Date: Thu, 18 Aug 2022 13:29:55 +0200 Subject: [PATCH 19/21] AmstradCPC Sources / CP/M fixes --- 8080/AmstradCPC/AMSDOS.SCR | 1 + 8080/AmstradCPC/ASS8080.SCR | 1 + 8080/AmstradCPC/ASSTRAN.SCR | 1 + 8080/AmstradCPC/ATARI.SCR | 1 + 8080/AmstradCPC/COPY.SCR | 1 + 8080/AmstradCPC/DISASS.SCR | 1 + 8080/AmstradCPC/DOUBLE.SCR | 1 + 8080/AmstradCPC/EDITOR.SCR | 1 + 8080/AmstradCPC/FILEINT.SCR | 1 + 8080/AmstradCPC/GRAFDEMO.SCR | 1 + 8080/AmstradCPC/GRAFIK.SCR | 1 + 8080/AmstradCPC/HASHCASH.SCR | 1 + 8080/AmstradCPC/INSTALL.SCR | 1 + 8080/AmstradCPC/KERNEL.COM | Bin 0 -> 13440 bytes 8080/AmstradCPC/MATHE.SCR | 1 + 8080/AmstradCPC/PORT8080.SCR | 1 + 8080/AmstradCPC/PORTZ80.SCR | 1 + 8080/AmstradCPC/PRIMED.SCR | 1 + 8080/AmstradCPC/PRINTER.SCR | 1 + 8080/AmstradCPC/READ.ME | 123 +++++++++++++++++++++++++++++++++++ 8080/AmstradCPC/RELOCATE.SCR | 1 + 8080/AmstradCPC/SAVESYS.SCR | 1 + 8080/AmstradCPC/SEE.SCR | 1 + 8080/AmstradCPC/SIMPFILE.SCR | 1 + 8080/AmstradCPC/SOURCE.SCR | 1 + 8080/AmstradCPC/STARTUP.SCR | 1 + 8080/AmstradCPC/TASKER.SCR | 1 + 8080/AmstradCPC/TERMINAL.SCR | 1 + 8080/AmstradCPC/TIMES.SCR | 1 + 8080/AmstradCPC/TOOLS.SCR | 1 + 8080/AmstradCPC/TURTDEMO.SCR | 1 + 8080/AmstradCPC/TURTLE.SCR | 1 + 8080/AmstradCPC/VDOS62KX.SCR | 1 + 8080/AmstradCPC/VOLKS4TH.COM | Bin 0 -> 29952 bytes 8080/AmstradCPC/XINOUT.SCR | 1 + 8080/CPM/startup.fb | 2 +- 8080/CPM/volks4th.com | Bin 29952 -> 25088 bytes 37 files changed, 156 insertions(+), 1 deletion(-) create mode 100644 8080/AmstradCPC/AMSDOS.SCR create mode 100644 8080/AmstradCPC/ASS8080.SCR create mode 100644 8080/AmstradCPC/ASSTRAN.SCR create mode 100644 8080/AmstradCPC/ATARI.SCR create mode 100644 8080/AmstradCPC/COPY.SCR create mode 100644 8080/AmstradCPC/DISASS.SCR create mode 100644 8080/AmstradCPC/DOUBLE.SCR create mode 100644 8080/AmstradCPC/EDITOR.SCR create mode 100644 8080/AmstradCPC/FILEINT.SCR create mode 100644 8080/AmstradCPC/GRAFDEMO.SCR create mode 100644 8080/AmstradCPC/GRAFIK.SCR create mode 100644 8080/AmstradCPC/HASHCASH.SCR create mode 100644 8080/AmstradCPC/INSTALL.SCR create mode 100644 8080/AmstradCPC/KERNEL.COM create mode 100644 8080/AmstradCPC/MATHE.SCR create mode 100644 8080/AmstradCPC/PORT8080.SCR create mode 100644 8080/AmstradCPC/PORTZ80.SCR create mode 100644 8080/AmstradCPC/PRIMED.SCR create mode 100644 8080/AmstradCPC/PRINTER.SCR create mode 100644 8080/AmstradCPC/READ.ME create mode 100644 8080/AmstradCPC/RELOCATE.SCR create mode 100644 8080/AmstradCPC/SAVESYS.SCR create mode 100644 8080/AmstradCPC/SEE.SCR create mode 100644 8080/AmstradCPC/SIMPFILE.SCR create mode 100644 8080/AmstradCPC/SOURCE.SCR create mode 100644 8080/AmstradCPC/STARTUP.SCR create mode 100644 8080/AmstradCPC/TASKER.SCR create mode 100644 8080/AmstradCPC/TERMINAL.SCR create mode 100644 8080/AmstradCPC/TIMES.SCR create mode 100644 8080/AmstradCPC/TOOLS.SCR create mode 100644 8080/AmstradCPC/TURTDEMO.SCR create mode 100644 8080/AmstradCPC/TURTLE.SCR create mode 100644 8080/AmstradCPC/VDOS62KX.SCR create mode 100644 8080/AmstradCPC/VOLKS4TH.COM create mode 100644 8080/AmstradCPC/XINOUT.SCR diff --git a/8080/AmstradCPC/AMSDOS.SCR b/8080/AmstradCPC/AMSDOS.SCR new file mode 100644 index 0000000..0d69633 --- /dev/null +++ b/8080/AmstradCPC/AMSDOS.SCR @@ -0,0 +1 @@ +\ Calling ROM fuer Standard 3" Laufwerk Amsdos UH 03Dec86 Dieses File enthaelt die Definitionen der Schnittstelle fuer Firmware-Aufrufe unter dem 38K-CP/M, das mit den Standard 3" Floppylaufwerken und ohne Speichererweiterung gefahren wird. Bei anderen Systemkonfigurationen (Vortex-Laufwerke und/oder Speichererweiterung) kann es sein, dass die Firmware-Aufrufe anders organisiert sein muessen. (Siehe VDOS62KX.SCR) Dieses File wird von dem Grafikpaket geladen, falls der entsprechende Kommentar in GRAFIK.SCR richtig gesetzt ist. \ Calling ROM fuer Standard 3" Laufwerk Amsdos UH 29Nov86 Assembler definitions Variable 'start Create jumprom \ Startaddr in 'start, returns like a subroutineAssembler H push 'start lhld xthl ret end-code ' noop Alias +org immediate \ No newline at end of file diff --git a/8080/AmstradCPC/ASS8080.SCR b/8080/AmstradCPC/ASS8080.SCR new file mode 100644 index 0000000..ce1c1b4 --- /dev/null +++ b/8080/AmstradCPC/ASS8080.SCR @@ -0,0 +1 @@ +\ VolksForth 8080 Assembler UH 09Mar86 Ideen lieferten: John Cassady Mike Perry Klaus Schleisiek Bernd Pennemann Dietrich Weineck \ VolksForth 8080 Assembler Load Screen UH 03Jun86Onlyforth Assembler also definitions hex 1 6 +THRU cr .( VolksForth 8080-Assembler geladen. ) cr OnlyForth \ Vektorisierte Erzeugung UH 03Jun86Variable >codes | Create nrc ] c, , c@ here allot ! c! [ : nonrelocate ( -- ) nrc >codes ! ; nonrelocate | : >exec ( n -- n+2 ) Create dup c, 2+ does> c@ >codes @ + perform ; 0 | >exec >c, | >exec >, | >exec >c@ | >exec >here | >exec >allot | >exec >! | >exec >c! drop \ Register und Definierende Worte UH 09Mar86 7 Constant A 0 Constant B 1 Constant C 2 Constant D 3 Constant E 0 Constant I 1 Constant I' 2 Constant W 3 Constant W' 0 Constant IP 1 Constant IP' 4 Constant H 5 Constant L 6 Constant M 6 Constant PSW 6 Constant SP 6 Constant S | : 1MI Create >c, does> C@ >c, ; | : 2MI Create >c, does> C@ + >c, ; | : 3MI Create >c, does> C@ swap 8 * + >c, ; | : 4MI Create >c, does> C@ >c, >c, ; | : 5MI Create >c, does> C@ >c, >, ; \ Mnemonics UH 09Mar8600 1MI nop 76 1MI hlt F3 1MI di FB 1MI ei 07 1MI rlc 0F 1MI rrc 17 1MI ral 1F 1MI rar E9 1MI pchl EB 1MI xchg C9 1MI ret C0 1MI rnz C8 1MI rz D0 1MI rnc D8 1MI rc 2F 1MI cma 37 1MI stc 3F 1MI cmc F9 1MI sphl E3 1MI xthl E0 1MI rpo E8 1MI rpe F8 1MI rm 27 1MI daa 80 2MI add 88 2MI adc 90 2MI sub 98 2MI sbb A0 2MI ana A8 2MI xra B0 2MI ora B8 2MI cmp 02 3MI stax 04 3MI inr 03 3MI inx 09 3MI dad 0B 3MI dcx C1 3MI pop C5 3MI push C7 3MI rst 05 3MI dcr 0A 3MI ldax D3 4MI out DB 4MI in C6 4MI adi CE 4MI aci D6 4MI sui DE 4MI sbi E6 4MI ani EE 4MI xri F6 4MI ori FE 4MI cpi 22 5MI shld CD 5MI call 2A 5MI lhld 32 5MI sta 3A 5MI lda C3 5MI jmp C2 5MI jnz CA 5MI jz D2 5MI jnc DA 5MI jc E2 5MI jpo EA 5MI jpe F2 5MI jp FA 5MI jm \ Spezial Mnemonics und Spruenge UH 09Mar86DA Constant C0= D2 Constant C0<> D2 Constant CS C2 Constant 0= CA Constant 0<> E2 Constant PE F2 Constant 0< FA Constant 0>= : not 8 [ FORTH ] xor ; : mov 8 * 40 + + >c, ; : mvi 8 * 6 + >c, >c, ; : lxi 8 * 1+ >c, >, ; : [[ ( -- addr ) >here ; \ BEGIN : ?] ( addr opcode -- ) >c, >, ; \ UNTIL : ?[ ( opcode -- addr ) >c, >here 0 >, ; \ IF : ?[[ ( addr -- addr' addr ) ?[ swap ; \ WHILE : ]? ( addr -- ) >here swap >! ; \ THEN : ][ ( addr -- addr' ) >here 1+ 0 jmp swap ]? ; \ ELSE : ]] ( addr -- ) jmp ; \ AGAIN : ]]? ( addr addr' -- ) jmp ]? ; \ REPEAT \ Macros UH 14May86: end-code context 2- @ context ! ; : ;c: 0 recover call end-code ] ; : Next >next jmp ; : rpush ( reg -- ) RP lhld H dcx DUP M mov ( high ) H dcx 1+ M mov ( low ) RP shld ; : rpop ( reg -- ) RP lhld M over 1+ mov ( low ) H inx M swap mov ( high ) H inx RP shld ; \ rpush und rpop gehen nicht mit HL : mvx ( src dest -- ) 2dup mov ( high ) 1+ swap 1+ swap mov ( low ) ; \ Definierende Worte UH 06Aug86Forth definitions : Code ( -- ) Create here dup 2- ! Assembler ; : ;Code ( -- ) 0 ?pairs compile [ ' does> >body 2+ @ , ] reveal [compile] [ Assembler ; immediate : >label ( adr -- ) here | Create swap , 4 hallot >here 4 - heap 4 cmove heap last @ (name> ! dp ! does> ( -- adr ) @ State @ IF [compile] Literal THEN ; : Label [ Assembler ] >here >label Assembler ; UH 14May86 % VolksForth 8080 Assembler Shadow-Screens UH 09Mar86 % VolksForth 8080 Assembler UH 03Jun86 Der 8080 Assembler wurde von John Cassady, in den Forth Dimensions veroeffentlicht und von Mike Perry im F83 implementiert. Er unterstuetzt den gesamten 8080 Befehlsvorrat und auch Befehle zur strukturierten Assemblerprogrammierung. Um ein Wort in Assembler zu definieren wird das definierende Wort Code benutzt, es kann, muss aber nicht mit end-code beendetwerden. Wie der Assembler arbeitet ist ein interessantes Beispiel fuer die Maechtigkeit von Create does>. Am Anfang werden die Befehle in Klassen eingeteilt und fuer jede Klasse ein definierndes Wort definiert. Wenn der Mnemonic des Befehls spaeter interpretiert wird, kompiliert er den entsprechenden Opcode. % Vektorisierte Erzeugung UH 09Mar86Zeigt Auf die Tabelle mit den aktuellen Erzeugungs-Operatoren. Tabelle mit Erzeugungs-Operatoren fuer In-Line Assembler Schaltet Assembler in den In-Line Modus. Definierendes Wort fuer Erzeugungs-Operator-Namen. Die Erzeugungs-Operator-Namen, sie fuehren den entsprechenden aktuellen Erzeugungsoperator aus. Mit diesen Erweiterungen kann der Assembler auch fuer den Target-Compiler benutzt werden. % Register und Definierende Worte UH 09Mar86 Die 8080 Register werden definiert. Es sind einfach Konstanten die Information fuer die Mnemonics hinterlassen. Einige Register der Forth-Maschine: IP ist BC, W ist DE Definierende Worte fuer die Mnemonics. Fast alle 8080 Befehle fallen in diese 5 Klassen. % Mnemonics UH 09Mar86Die 8080 Mnemonics werden definiert. % Spezial Mnemonics und Spruenge UH 09Mar86Vergleiche des 8080 not folgt einem Vergleich, wenn er invertiert werden soll. die Mnemonics, die sich nicht in die Klassen MI1 bis MI5 einteilen lassen. Die strukturierten Assembler-Anweisungen. Die 'Fleischerhaken' werden benutzt, damit keine Verwechselungenzu den strukturierten Anweisungen in Forth entstehen. Es findet keine Absicherung der Kontrollstrukturen statt, sodasssie auch beliebig missbraucht, werden koennen. Das ist manchmal aus Geschwindigkeitsgruenden leider notwendig. % Macros UH 17May86end-code beendet eine Code-Definition ;c: Erlaubt das Einbinden von High-Level Forth in Code-Worten. Next Assembliert einen Sprung zum Adress-Interpretierer. rpush Das angegebene Register wird auf den Return-Stack gelegt. rpop Das angegebene Register wird vom Return-Stack genommen. rpush und rpop benutzen das HL Register. mvx Ein 16-Bit-Move wie 'mov' fuer 8-Bit Register Bewegt Registerpaare HL BC DE % Definierende Worte UH 17May86Code leitet eine Code-Definition ein. ;code ist das Low-Level-Aequivalent von does> >label erzeugt ein Label auf dem Heap, mit dem angegebenen Wert Label erzeugt ein Label auf dem Heap, mit dem Wert von here \ No newline at end of file diff --git a/8080/AmstradCPC/ASSTRAN.SCR b/8080/AmstradCPC/ASSTRAN.SCR new file mode 100644 index 0000000..4e1447f --- /dev/null +++ b/8080/AmstradCPC/ASSTRAN.SCR @@ -0,0 +1 @@ +\\ Transinient Assembler 11Nov86 Dieses File enthaelt Befehle, die den Assembler vollstaendig in den Heap laden, so dass er schliesslich mit clear wieder vergessen werden kann. Dadurch ist es nicht notwendig in einer Anwendung den ganzen Assembler im Speicher lassen zu muessen, nur weil einige primitive Worte in Assembler geschrieben sind. \ Internal Assembler UH 22Oct86 Onlyforth here $C00 hallot heap dp ! include ass8080.scr dp ! \ No newline at end of file diff --git a/8080/AmstradCPC/ATARI.SCR b/8080/AmstradCPC/ATARI.SCR new file mode 100644 index 0000000..cf39370 --- /dev/null +++ b/8080/AmstradCPC/ATARI.SCR @@ -0,0 +1 @@ +\ Anpassung an C64 und Atari-Graphic UH 03Dec86 Dieses File enthaelt im wesentlichen Umbenennungen der Grafik- routinen, da die Grafikpakete auf dem C64 und dem Atari zum Teil andere Namen verwenden, als die AMSTRAD Programmierer sie sich ausgedacht haben. Um die Atari und C64 Grafik-Demos weitgehend uebernehmen zu koennen wird also dieses Schicht zusaetzlich vom File GRAFDEMO.SCR geladen. \ Anpassung an C64 und Atari-Graphic UH 05Sep86 ' move Alias set ' line Alias draw ' mover Alias rset ' liner Alias rdraw : line ( x1 y1 x2 y2 -- ) set draw ; | Create cur 4 allot : cur.x ( -- addr ) cursor@ cur 2! cur 2+ ; : cur.y ( -- addr ) cursor@ cur 2! cur ; : home ( -- ) 0 0 move ; : exorwrite 1 access ; : overwrite 3 access ; --> \ Anpassung an C64 und Atari-Graphic UH 05Sep86 ' test Alias get.pixel ( x y -- p ) : put.pixel ( x y p -- ) pen plot ; : clip.window ( x1 y1 x2 y2 -- ) rot heigth width ; : unplot ( x y -- ) paper@ put.pixel ; 05Sep86 05Sep86 \ No newline at end of file diff --git a/8080/AmstradCPC/COPY.SCR b/8080/AmstradCPC/COPY.SCR new file mode 100644 index 0000000..30357c5 --- /dev/null +++ b/8080/AmstradCPC/COPY.SCR @@ -0,0 +1 @@ +\ Copy und Convey 19Nov87 Dieses File enthaelt Definitionen, die urspruenglich im Kern enthalten waren. Sie sind jetzt ausgelagert worden, um den Kern klein zu halten. copy kopiert einen Screen convey kopiert einen Bereich von Screens \ moving blocks 20Oct86 19Nov87| : full? ( -- flag ) prev BEGIN @ dup @ 0= UNTIL 6 + @ 0< ; | : fromblock ( blk -- adr ) fromfile @ (block ; | : (copy ( from to -- ) dup isfile@ core? IF prev @ emptybuf THEN full? IF save-buffers THEN offset @ + isfile@ rot fromblock 6 - 2! update ; | : blkmove ( from to quan --) save-buffers >r over r@ + over u> >r 2dup u< r> and IF r@ r@ d+ r> 0 ?DO -1 -2 d+ 2dup (copy LOOP ELSE r> 0 ?DO 2dup (copy 1 1 d+ LOOP THEN save-buffers 2drop ; : copy ( from to --) 1 blkmove ; : convey ( [blk1 blk2] [to.blk --) swap 1+ 2 pick - dup 0> not Abort" Nein !" blkmove ; \ No newline at end of file diff --git a/8080/AmstradCPC/DISASS.SCR b/8080/AmstradCPC/DISASS.SCR new file mode 100644 index 0000000..08ae90c --- /dev/null +++ b/8080/AmstradCPC/DISASS.SCR @@ -0,0 +1 @@ +\\ Z80-Disassembler 08Nov86 Dieses File enthaelt einen Z80-Disassembler, der assemblierten Code in Standard Zilog-Z80 Mnemonics umsetzt. Benutzung: TOOLS ALSO \ Schalte Disassembler-Vokabular an addr DIS \ Disassembliere ab Adresse addr xxxx displace ! \ Beruecksichte bei allen Adressen einen \ Versatz von xxxx. \ Wird gebraucht, wenn ein Assemblerstueck \ nicht an dem Platz disassembliert wird, \ an dem es ablaeuft. \ Z80-Disassembler Load Screen 08Nov86 Onlyforth Tools also definitions hex ' Forth | Alias F: immediate ' Tools | Alias T: immediate 1 $10 +THRU cr .( Disassembler geladen. ) cr OnlyForth \\ Fragen Anregungen & Kritik an: U. Hoffmann Harmsstrasse 71 2300 Kiel 1 \ Speicherzugriff und Ausgabe 07Jul86internal \needs Case: : Case: Create: Does> swap 2* + perform ; Variable index Variable address Variable offset Variable oldoutput external Variable displace displace off internal ' pad Alias str1 ( -- addr ) : str2 ( -- addr ) str1 $40 + ; : byte ( -- b ) address @ displace @ + c@ ; : word ( -- w ) address @ displace @ + @ ; : .byte ( byte -- ) 0 <# # #s #> type ; : .word ( addr -- ) 0 <# # # # #s #> type ; \ neue Bytes lesen Byte-Fraktionen 07Jul86 : next-byte output push oldoutput @ output ! byte .byte space 1 address +! ; : next-word next-byte next-byte ; : f ( -- b ) byte $40 / ; : g ( -- b ) byte 8 / 7 and ; : h ( -- b ) byte 7 and ; : j ( -- b ) g 2/ ; : k ( -- b ) g 1 and ; \\ 76543210 ffggghhh jjk \ Select" 08Nov86 : scan/ ( limit start -- limit start' ) over swap DO I c@ Ascii / = IF I F: ENDLOOP T: exit THEN LOOP dup ; : select ( n addr len -- addr' len' ) bounds rot 0 ?DO scan/ 1+ 2dup < IF 2drop " -" count ENDLOOP exit THEN LOOP under scan/ nip over - ; : (select" ( n -- ) "lit count select type ; : select" ( -- ) compile (select" ," ; immediate : append ( c str -- ) under count + c! dup c@ 1+ swap c! ; \ StringOutput 07Jul86 Variable $ : $emit ( c -- ) $ @ append pause ; : $type ( adr len -- ) 0 ?DO count $emit LOOP drop ; : $cr ( -- ) $ @ off ; : $at? ( -- row col ) 0 $ @ c@ ; Output: $output $emit $cr $type noop $cr 2drop $at? ; \ Register 07Jul86 : reg ( n -- ) dup 5 = IF index @ negate index ! THEN select" B/C/D/E/H/L/$/A" ; : double-reg ( n -- ) select" BC/DE/%/SP" ; : double-reg2 ( n -- ) select" BC/DE/%/AF" ; : num ( n -- ) select" 0/1/2/3/4/5/6/7" ; : cond ( n -- ) select" nz/z/nc/c/po/pe/p/m" ; : arith ( n -- ) select" add A,/adc A,/sub /sbc A,/and /xor /or /cp " ; \ no-prefix Einteilung der Befehle in Klassen 07Jul86 : 00xxx000 g dup 3 > IF ." jr " 4- cond ." ,?" exit THEN select" nop/ex AF,AF'/djnz ?/jr ?" ; : 00xxx001 k IF ." add %," j double-reg exit THEN ." ld " j double-reg ." ,&" ; : 00xxx010 ." ld " g select" (BC),A/A,(BC)/(DE),A/A,(DE)/(&),%/%,(&)/(&),A/A,(&)" ; : 00xxx011 k IF ." dec " ELSE ." inc " THEN j double-reg ; \ no-prefix 07Jul86 : 00xxx100 ." inc " g reg ; : 00xxx101 ." dec " g reg ; : 00xxx110 ." ld " g reg ." ,#" ; : 00xxx111 g select" rlca/rrca/rla/rra/daa/cpl/scf/ccf" ; : 01xxxxxx ." ld " g reg ." ," h reg ; : 10xxxxxx g arith h reg ; \ no-prefix 07Jul86 : 11xxx000 ." ret " g cond ; : 11xxx001 k IF j select" ret/exx/jp (%)/ld sp,%" exit THEN ." pop " j double-reg2 ; : 11xxx010 ." JP " g cond ." ,&" ; : 11xxx011 g select" jp &/-/out (#),A/in a,(#)/ex (SP),%/ex DE,HL/di/ei" ; : 11xxx100 ." call " g cond ; : 11xxx101 k IF ." call &" exit THEN ." push " j double-reg2 ; : 11xxx110 g arith ." #" ; : 11xxx111 ." rst " g select" 00/08/10/18/20/28/30/38" ; \ no-prefix 07Jul86 Case: 00xxxhhh 00xxx000 00xxx001 00xxx010 00xxx011 00xxx100 00xxx101 00xxx110 00xxx111 ; Case: 11xxxhhh 11xxx000 11xxx001 11xxx010 11xxx011 11xxx100 11xxx101 11xxx110 11xxx111 ; : 00xxxxxx h 00xxxhhh ; : 11xxxxxx h 11xxxhhh ; Case: ffxxxxxx 00xxxxxx 01xxxxxx 10xxxxxx 11xxxxxx ; \ no-prefix 07Jul86 : get-offset index @ 0> IF byte offset ! next-byte THEN ; : no-prefix f ffxxxxxx next-byte get-offset ; \ CB-Prefix 07Jul86 : CB-00xxxxxx g select" rlc /rrc /rl /rr /sla /sra /-/srl " h reg ; : CB-01xxxxxx ." bit " g num ." ," h reg ; : CB-10xxxxxx ." res " g num ." ," h reg ; : CB-11xxxxxx ." set " g num ." ," h reg ; case: singlebit CB-00xxxxxx CB-01xxxxxx CB-10xxxxxx CB-11xxxxxx ; : CB-prefix get-offset f singlebit next-byte ; \ ED-Prefix 30Sep86: ED-01xxx000 ." in (C)," g reg ; : ED-01xxx001 ." out (C)," g reg ; : ED-01xxx010 k IF ." adc " ELSE ." sbc " THEN ." HL," j double-reg ; : ED-01xxx011 ." ld " k IF j double-reg ." ,(&)" exit THEN ." (&)," j double-reg ; : ED-01xxx100 ." neg" ; : ED-01xxx101 k IF ." reti" exit THEN ." retn" ; : ED-01xxx110 g select" im 0/-/im 1/im 2" ; : ED-01xxx111 g select" ld I,A/ld R,A/ld A,I/ld A,R/rrd/rld" ; : ED-10xxxxxx h select" ld/cp/in/ot" g 4- select" i/d/ir/dr" ; Case: ED-01xxxhhh ED-01xxx000 ED-01xxx001 ED-01xxx010 ED-01xxx011 ED-01xxx100 ED-01xxx101 ED-01xxx110 ED-01xxx111 ; : ED-01xxxxxx h ED-01xxxhhh ; \ ED-Prefix 07Jul86 Case: extended noop ED-01xxxxxx ED-10xxxxxx noop ; : ED-prefix get-offset f extended next-byte ; \ Disassassemblieren eines einzelnen Befehls 30Sep86 : index-register ( n -- ) index ! next-byte ; : get-instruction ( -- ) index off str1 $ ! cr byte $DD = IF 1 index-register ELSE byte $FD = IF 2 index-register THEN THEN byte $76 case? IF next-byte ." halt" exit THEN $CB case? IF next-byte CB-prefix exit THEN $ED case? IF next-byte ED-prefix exit THEN drop no-prefix ; \ Adressierungsarten ausgeben 07Jul86 27Nov87: .index-register ( -- ) index @ abs select" HL/IX/IY" ; : offset-sign ( o -- o' ) dup $7F > IF $100 - THEN ; : +- ( s -- ) 0< IF Ascii - ELSE Ascii + THEN hold ; : .offset ( -- ) offset @ offset-sign extend under dabs <# # #s rot +- #> type ; : .index-register-offset index @ abs dup select" (HL)/(IX/(IY" IF .offset ." )" THEN ; : .inline-byte ( -- ) byte .byte next-byte ; : .inline-word ( -- ) word .word next-word ; : .displace ( -- ) byte offset-sign address @ + 1+ .word next-byte ; \ Hauptebene: dis 07Jul86: .char ( c -- ) Ascii % case? IF .index-register exit THEN Ascii $ case? IF .index-register-offset exit THEN Ascii # case? IF .inline-byte exit THEN Ascii & case? IF .inline-word exit THEN Ascii ? case? IF .displace exit THEN emit ; : instruction ( -- ) cr address @ .word 2 spaces output @ oldoutput ! $output get-instruction str2 $ ! cr str1 count 0 ?DO count .char LOOP drop oldoutput @ output ! $20 col - 0 max spaces str2 count type ; external : dis ( addr -- ) address ! BEGIN instruction stop? UNTIL ; \ No newline at end of file diff --git a/8080/AmstradCPC/DOUBLE.SCR b/8080/AmstradCPC/DOUBLE.SCR new file mode 100644 index 0000000..a7c6663 --- /dev/null +++ b/8080/AmstradCPC/DOUBLE.SCR @@ -0,0 +1 @@ +\\ Double words 11Nov86 Dieses File enthaelt Worte fuer 32-Bit Objekte. Im Kern bereits enthalten sind: 2@ 2! 2dup 2drop 2swap dnegate d+ Hier werden definiert: 2Variable 2Constant 2over d* \ 2over 2@ 2! 2Variable 2Constant UH 30Oct86 : 2Variable Variable 2 allot ; : 2Constant Create , , does> 2@ ; Code 2over ( 32b1 32b2 -- 32b1 32b2 32b1 ) 7 H lxi SP dad M D mov H dcx M E mov D push H dcx M D mov H dcx M E mov D push Next end-code --> \\ Code 2@ ( addr -- 32b ) H pop H push H inx H inx M E mov H inx M D mov H pop D push M E mov H inx M D mov D push Next end-code Code 2! ( 32b addr -- ) H pop D pop E M mov H inx D M mov H inx D pop E M mov H inx D M mov Next end-code \ d* d- 29Jun86 : d* ( d1 d2 -- d1*d2 ) rot 2over rot um* 2swap um* d+ 2swap um* d+ ; : d- ( d1 d2 -- d1-d2 ) dnegate d+ ; \ No newline at end of file diff --git a/8080/AmstradCPC/EDITOR.SCR b/8080/AmstradCPC/EDITOR.SCR new file mode 100644 index 0000000..6eedfcd --- /dev/null +++ b/8080/AmstradCPC/EDITOR.SCR @@ -0,0 +1 @@ +\ Full-Screen Editor UH 02Nov86 Dieses File enthaelt den Full-Screen Editor fuer die CP/M - volksFORTH-Version. Er enthaelt Line- und Chararcter-Stacks, Find&Replace-Funktion sowie Unterstuetzung des Shadow-Screen-Konzepts, der view- Funktion und des sichtbaren Laden von Screens (showload). Durch die integrierte Tastaturtabelle (keytable) laesst sich dieKommandobelegung der Tasten auf einfache Art und Weise aendern. Anregungen, Kritik und Verbesserungsvorschlaege bitte an: U. Hoffmann Harmsstrasse 71 2300 Kiel \ Load Screen for the Editor UH 03Nov86 UH 27Nov87 Onlyforth cr 1 $1E +thru Onlyforth \ String primitves 27Nov87 : delete ( buffer size count -- ) over umin dup >r - 2dup over r@ + -rot cmove + r> bl fill ; : insert ( string length buffer size -- ) rot over umin dup >r - over dup r@ + rot cmove> r> cmove ; : replace ( string length buffer size -- ) rot umin cmove ; \ usefull definitions and Editor vocabulary UH 27Nov87 : blank ( addr len -- ) bl fill ; : ?enough ( n --) depth 1- > abort" Not enough Parameters" ; : ?abort( ( f -- ) IF [compile] .( true abort" !" THEN [compile] ( ; Vocabulary Editor ' Forth | Alias F: immediate ' Editor | Alias E: immediate Editor also definitions \ move cursor with position-checking 23Nov86 | : c ( n --) \ checks the cursor position r# @ + dup 0 b/blk uwithin not Abort" There is a border!" r# ! ; \\ : c ( n --) \ goes thru the screens r# @ + dup b/blk 1- > IF 1 scr +! THEN dup 0< IF -1 scr +! THEN b/blk mod r# ! ; : c ( n --) \ moves cyclic thru the screen r# @ + b/blk mod r# ! ; \ calculate addresses UH 31Oct86 | Code *line ( l -- adr ) H pop H dad H dad H dad H dad H dad H dad Hpush jmp end-code | Code /line ( n -- c l ) H pop L A mov $3F ani A E mov 0 D mvi L A mov ral A L mov H A mov ral A H mov L A mov ral A L mov H A mov ral A H mov L A mov ral 3 ani H L mov A H mov dpush jmp end-code \\ | : *line ( l -- adr ) c/l * ; | : /line ( n -- c l ) c/l /mod ; \ calculate addresses UH 01Nov86 | : top ( -- ) r# off ; | : cursor ( -- n ) r# @ ; | : 'start ( -- adr ) scr @ block ; | : 'end ( -- adr ) 'start b/blk + ; | : 'cursor ( -- adr ) 'start cursor + ; | : position ( -- c l ) cursor /line ; | : line# ( -- l ) position nip ; | : col# ( -- c ) position drop ; | : 'line ( -- adr ) 'start line# *line + ; | : 'line-end ( -- adr ) 'line c/l + 1- ; | : #after ( -- n ) c/l col# - ; | : #remaining ( -- n ) b/blk cursor - ; | : #end ( -- n ) b/blk line# *line - ; \ move cursor directed UH 01Nov86 | : curup c/l negate c ; | : curdown c/l c ; | : curleft -1 c ; | : curright 1 c ; | : +tab \ 1/4 line forth cursor $10 / 1+ $10 * cursor - c ; | : -tab \ 1/8 line back cursor 8 mod negate dup 0= 8 * + c ; | : >""end 'start b/blk -trailing nip b/blk 1- min r# ! ; | : #after c ; \ show border UH 27Nov87&15 | Constant dx 1 | Constant dy | : horizontal ( row -- row' ) dup dx 1- at c/l 2+ 0 DO Ascii - emit LOOP 1+ ; | : vertical ( row -- row' ) l/s 0 DO dup dx 1- at Ascii | emit row dx c/l + at Ascii | emit 1+ LOOP ; | : border dy 1- horizontal vertical horizontal drop ; | : edit-at ( -- ) position swap dy dx d+ at ; Forth definitions : updated? ( -- f) scr @ block 2- @ 0< ; \ display screen UH 02Nov86 UH 27Nov87Editor definitions | Variable isfile' | Variable imode | : .updated ( -- ) 7 0 at updated? IF 4 spaces ELSE ." not " THEN ." updated" ; | : redisplay ( line# -- ) dup dy + dx at *line 'start + c/l type ; | : .file ( 'file -- ) [ Dos ] .file &14 col - 0 max spaces ; | : .title 1 0 at isfile@ .file 3 0 at isfile' @ .file 5 0 at ." Scr# " scr @ 4 .r .updated &10 0 at imode @ IF ." insert " exit THEN ." overwrite" ; | : .screen l/s 0 DO I redisplay LOOP ; | : .all .title .screen ; \ check errors UH 02Nov86 | : ?bottom ( -- ) 'end c/l - c/l -trailing nip Abort" You would lose a line" ; | : ?fit ( n -- ) 'line c/l -trailing nip + c/l > IF line# redisplay true Abort" You would lose a char" THEN ; | : ?end 1 ?fit ; \ programmer's id UH 02Nov86 $12 | Constant id-len Create id id-len allot id id-len erase | : stamp ( -- ) id 1+ count 'start c/l + over - swap cmove ; | : ?stamp ( -- ) updated? IF stamp THEN ; | : get-id ( -- ) id c@ ?exit id on cr ." Enter your ID : " at? $10 0 DO Ascii . emit LOOP at id id-len 2 /string expect rvsoff span @ id 1+ c! ; \ update screen-display UH 02Dec86 | : emptybuf prev @ 2+ dup on 4+ off ; | : undo emptybuf .all ; | : modified updated? ?exit update .updated ; | : linemodified modified line# redisplay ; | : screenmodified modified l/s line# ?DO I redisplay LOOP ; | : .modified ( -- ) dy l/s + 4+ 0 at scr @ . updated? not IF ." un" THEN ." modified" ?stamp ; \ leave editor UH 02Dec86 UH 23Feb88| Variable (pad (pad off | : memtop ( -- adr) sp@ $100 - ; | Create char 1 allot ( | Variable imode ) imode off | : setimode imode on .title ; | : clrimode imode off .title ; | : flipimode ( -- ) imode @ 0= imode ! .title ; | : done ( -- ) ['] (quit is 'quit ['] (error errorhandler ! quit ; | : update-exit ( -- ) .modified done ; | : flushed-exit ( -- ) .modified save-buffers done ; \ handle lines UH 01Nov86 | : (clear-line 'line c/l blank ; | : clear-line (clear-line linemodified ; | : clear> 'cursor #after blank linemodified ; | : delete-line 'line #end c/l delete screenmodified ; | : backline curup delete-line ; | : (insert-line ?bottom 'line c/l over #end insert (clear-line ; | : insert-line (insert-line screenmodified ; \ handle characters UH 01Nov86 | : delete-char 'cursor #after 1 delete linemodified ; | : backspace curleft delete-char ; | : (insert-char ?end 'cursor 1 over #after insert ; | : insert-char (insert-char bl 'cursor c! linemodified ; | : putchar ( --) char c@ imode @ IF (insert-char THEN 'cursor c! linemodified curright ; \ stack lines UH 31Oct86 | Create lines 4 allot \ { 2+pointer | 2base } | : 'lines ( -- adr) lines 2@ + ; | : @line 'lines memtop u> Abort" line buffer full" 'line 'lines c/l cmove c/l lines +! ; | : copyline @line curdown ; | : line>buf @line delete-line ; | : !line c/l negate lines +! 'lines 'line c/l cmove ; | : buf>line lines @ 0= Abort" line buffer empty" ?bottom (insert-line !line screenmodified ; \ stack characters UH 01Nov86 | Create chars 4 allot \ { 2+pointer | 2base } | : 'chars ( -- adr) chars 2@ + ; | : @char 'chars 1- lines 2+ @ u> Abort" char buffer full" 'cursor c@ 'chars c! 1 chars +! ; | : copychar @char curright ; | : char>buf @char delete-char ; | : !char -1 chars +! 'chars c@ 'cursor c! ; | : buf>char chars @ 0= Abort" char buffer empty" ?end (insert-char !char linemodified ; \ switch screens UH 03Nov86 UH 27Nov87 | Variable r#' r#' off | Variable scr' scr' off ( | Variable isfile' ) isfile@ isfile' ! | : associate \ switch to alternate screen isfile' @ isfile@ isfile' ! isfile ! scr' @ scr @ scr' ! scr ! r#' @ r# @ r#' ! r# ! ; | : mark isfile@ isfile' ! scr @ scr' ! r# @ r#' ! .title ; | : n ?stamp 1 scr +! .all ; | : b ?stamp -1 scr +! .all ; | : a ?stamp associate .all ; \ shadow screens UH 03Nov86 Variable shadow shadow off | : (shadow isfile@ IF capacity 2/ exit THEN shadow @ ; | : >shadow ?stamp \ switch to shadow screen (shadow dup scr @ u> not IF negate THEN scr +! .all ; \ load and show screens UH 06Mar88 ' name >body &10 + | Constant 'name | : showoff ['] exit 'name ! curoff rvsoff ; | : show ( -- ) blk @ 0= IF showoff exit THEN >in @ 1- r# ! curoff edit-at curon stop? IF showoff true Abort" Break! " THEN blk @ scr @ - IF blk @ scr ! rvsoff curoff .all rvson curon THEN ; | : showload ( -- ) ?stamp save-buffers ['] show 'name ! curon rvson ['] .status >body push ['] noop is .status scr @ scr push scr off r# push r# @ (load showoff ; \ find strings UH 01Nov86 | Variable insert-buffer | Variable find-buffer | : 'insert ( -- addr ) insert-buffer @ ; | : 'find ( -- addr ) find-buffer @ ; | : .buf ( addr -- ) count type ." |" &80 col - spaces ; | : get ( addr -- ) >r at? r@ .buf 2dup at r@ 1+ c/l expect span @ ?dup IF r@ c! THEN at r> .buf ; | : get-buffers dy l/s + 2+ dx 1- 2dup at ." find: |" 'find get swap 1+ swap 2- at ." ? replace: |" 'insert get ; \ search for string UH 02Nov86 UH 27Nov87 | : skip ( addr -- addr' ) 'find c@ + ; | : find? ( -- addr T | F ) 'find count 'cursor #remaining "search ; | : "find ( -- r# scr ) find? IF skip 'start - scr @ exit THEN ?stamp capacity scr @ 1+ ?DO 'find count I dup 5 5 at 4 .r block b/blk "search IF skip I block - I endloop exit THEN stop? Abort" Break! " LOOP true Abort" not found!" ; \ replace strings UH 03Nov86 UH 27Nov87| : replace? ( -- f ) dy l/s + 3+ dx 3 - at key dup #cr = IF line# redisplay true Abort" Break!" THEN capital Ascii R = ; | : "mark ( -- ) r# push 'find count dup negate c edit-at rvson type rvsoff ; | : (replace 'insert c@ 'find c@ - ?fit 'find c@ negate c 'cursor #after 'find c@ delete 'insert count 'cursor #after insert 'insert c@ c modified ; | : "replace get-buffers BEGIN "find dup scr @ - swap scr ! IF .all THEN r# ! "mark replace? IF (replace THEN line# redisplay REPEAT ;\ Control-Characters and special keys CPCs UH 04Dec86Forth definitions : Ctrl ( -- c ) name 1+ c@ $1F and state @ IF [compile] Literal THEN ; immediate $7F Constant #del Editor definitions \ Definition der Spezialtasten $F0 | Constant #up $F1 | Constant #down $F2 | Constant #left $F3 | Constant #right $E0 | Constant #copy $FC | Constant #esc | ' 4+ | Alias &s ( key -- key' ) | : &c ( key -- key' ) 8 + ; \ Try a Screen-Editor for CPCs UH 04Dec86 Create keytable #up c, #left c, #down c, #right c, #up &s c, #left &s c, #down &s c, #right &s c, Ctrl Q c, Ctrl Z c, Ctrl H c, Ctrl H c, #del c, Ctrl P c, #copy c, Ctrl D c, Ctrl T c, Ctrl I c, Ctrl O c, Ctrl C c, Ctrl E c, #cr c, #right &c c, #left &c c, #up &c c, #down &c c, Ctrl F c, Ctrl U c, Ctrl X c, #esc c, Ctrl L c, Ctrl W c, Ctrl N c, Ctrl B c, Ctrl A c, Ctrl R c, here keytable - Constant #keys \ Try a screen Editor UH 28Nov86 Create: actiontable curup curleft curdown curright line>buf char>buf buf>line buf>char copyline copychar backspace backspace backspace delete-char insert-char delete-line insert-line setimode clrimode clear-line clear> +tab -tab top >""end "replace undo update-exit flushed-exit showload >shadow n b a mark ; here actiontable - 2/ 1- #keys - ?abort( # of actions) \ find keys UH 01Nov86 | Code findkey ( key -- addr/default ) H pop L A mov keytable H lxi #keys $100 * D lxi [[ M cmp 0= ?[ actiontable H lxi 0 D mvi D dad D dad M E mov H inx M D mov D push next ]? H inx E inr D dcr 0= ?] ' putchar H lxi hpush jmp end-code \\ | : findkey ( key -- adr/default ) #keys 0 DO dup keytable F: I + c@ = IF drop E: actiontable F: I 2* + @ endloop exit THEN LOOP drop ['] putchar ; \ allocate buffers UH 01Nov86 c/l 2* | Constant cstack-size | : nextbuf ( adr -- adr' ) cstack-size + ; | : ?clearbuffer pad (pad @ = ?exit pad dup (pad ! nextbuf dup find-buffer ! 'find off nextbuf dup insert-buffer ! 'insert off nextbuf dup 0 chars 2! nextbuf 0 lines 2! ; \ enter and exit the editor, editor's loop UH 02Nov86| Variable jingle jingle on | : bell 07 con! jingle off ; | : clear-error jingle @ ?exit dy l/s + 1+ dx at c/l spaces jingle on ; | : fullquit BEGIN ?clearbuffer edit-at key dup char c! findkey execute clear-error REPEAT ; | : fullerror ( string --) jingle @ IF bell THEN dy l/s + 1+ dx $16 + at rvson count type rvsoff &80 col - spaces scr @ capacity 1- min 0 max scr ! .title quit ; | : install ( -- ) ['] fullquit Is 'quit ['] fullerror errorhandler ! ; \ enter and exit the Editor UH 02Nov86 Forth definitions : v ( -- ) E: 'start drop get-id install ?clearbuffer page curoff border .all quit ; : l ( scr -- ) 1 ?enough scr ! E: top F: v ; \ savesystem UH 27Nov87 : savesystem \ save image E: id off (pad off savesystem ; | : >find ?clearbuffer >in push bl word count 'find 1+ place bl 'find 1+ dup >r count dup >r + c! r> 2+ 'find c! bl r> c! ; : view ( --) >find ' >name 4- @ (view ?dup 0= Abort" hand made" scr ! E: top curdown find? 0= IF ." From Scr # " scr @ u. true Abort" wrong file" THEN skip 'start - 1- r# ! v ; \ No newline at end of file diff --git a/8080/AmstradCPC/FILEINT.SCR b/8080/AmstradCPC/FILEINT.SCR new file mode 100644 index 0000000..c969775 --- /dev/null +++ b/8080/AmstradCPC/FILEINT.SCR @@ -0,0 +1 @@ +\ CP/M 2.2 File-Interface (3.80a) UH 05Oct87 Dieses File enthaelt das File-Interface von volksFORTH zu CP/M. Damit ist Zugriff auf normale CP/M-Files moeglich. Wenn ein File mit USE benutzt wird, beziehen sich alle Worte, die mit dem Massenspeicher arbeiten, auf dieses File. Benutzung: USE \ benutze ein schon existierendes File FILE \ erzeuge ein Forthfile mit dem Namen . MAKE \ Erzeuge ein File mit und ordne \ es dem aktuellen Forthfile zu. MAKEFILE \ Erzeuge ein File mit CP/M und FORTH-Namen . INCLUDE \ Lade File mit Forthnamen ab Screen 1 DOS RESET \ zum Wechsel von Disketten. (Oh! CP/M) \ CP/M 2.2 File-Interface load-Screen UH 18Feb88OnlyForth 2 load \ view numbers for this file 3 4 thru \ DOS File Functions 5 $11 thru \ Forth File Functions $12 $16 thru \ User Interface File source.scr \ Define already existing Files File fileint.scr File startup.scr ' (makeview Is makeview ' remove-files Is custom-remove ' file-r/w Is r/w ' noop Is drvinit \ include startup.scr \ load Standard System \ Build correct view-numbers for this file UUH 19Nov87 | : fileintview ( -- ) $400 blk @ + ; ' fileintview Is makeview \ File Control Blocks UH 18Feb88Dos definitions also | : Fcbyte ( n len -- len' ) Create over c, + does> c@ + ; &11 Constant filenamelen 0 2 | Fcbyte nextfile immediate 1 Fcbyte drive ' drive | Alias >dosfcb filenamelen 3 - Fcbyte filename 3 Fcbyte extension &21 + \ ex, s1, s2, rc, d0, ... dn, cr 2 Fcbyte record \ r0, r1 1+ \ r2 2 Fcbyte opened 2 Fcbyte fileno 2 Fcbyte filesize \ in 128-Byte-Records 4 Fcbyte position Constant b/fcb \ dos primitives UH 10Oct87 ' 2- | Alias body> ' 2- | Alias dosfcb> : drive! ( drv -- ) $0E bdos ; : search0 ( dosfcb -- dir ) $11 bdosa ; : searchnext ( dosfcb -- dir ) $12 bdosa ; : read-seq ( dosfcb -- f ) $14 bdosa dos-error? ; : write-seq ( dosfcb -- f ) $15 bdosa dos-error? ; : createfile ( dosfcb -- f ) $16 bdosa dos-error? ; : size ( dos -- size ) dup $23 bdos dosfcb> record @ ; : drive@ ( -- drv ) 0 $19 bdosa ; : killfile ( dosfcb -- ) $13 bdos ; \ File sizes UH 05Oct87 : (capacity ( fcb -- n ) \ filecapacity in blocks filesize @ rec/blk u/mod swap 0= ?exit 1+ ; : in-range ( block fcb -- ) (capacity u< not Abort" beyond capacity!" ; Forth definitions : capacity ( -- n ) isfile@ (capacity ; Dos definitions \ (open UH 18Feb88 : (open ( fcb -- ) dup opened @ IF drop exit THEN dup position 0. rot 2! dup >dosfcb openfile Abort" not found!" dup opened on dup >dosfcb size swap filesize ! ; : (make ( fcb -- ) dup >dosfcb killfile dup >dosfcb createfile Abort" directory full!" dup position 0. rot 2! dup filesize off opened on offset off ; : file-r/w ( buffer block fcb f -- f ) over 0= Abort" no Direct Disk IO supported! " >r dup (open 2dup in-range r> (r/w ; \ Print Filenames UH 10Oct87 : .file ( fcb -- ) 0 case? IF ." DIRECT" exit THEN fcb dosfcb> case? IF ." DEFAULT" exit THEN body> >name .name ; : .drive ( fcb -- ) drive c@ ?dup 0=exit [ Ascii A 1- ] Literal + emit Ascii : emit ; : .dosfile ( fcb -- ) dup filename 8 -trailing type Ascii . emit extension 3 type ; \ Print Filenames UH 10Oct87 : tab ( -- ) col &59 > IF cr exit THEN &20 col &20 mod - 0 max spaces ; : .fcb ( fcb -- ) dup fileno @ 3 u.r tab dup .file tab dup .drive dup .dosfile tab dup opened @ IF ." opened" ELSE ." closed" THEN 3 spaces base push decimal (capacity 3 u.r ." kB" ; \ Filenames UH 05Oct87 : !name ( addr len fcb -- ) dup >r filename filenamelen bl fill over 1+ c@ Ascii : = IF over c@ [ Ascii A 1- ] Literal - >r 2 /string r> ELSE 0 THEN r@ drive c! r> dup filename 2swap filenamelen 1+ min bounds ?DO I c@ Ascii . = IF drop dup extension ELSE I c@ over c! 1+ THEN LOOP 2drop ; : !fcb ( fcb -- ) dup opened off name count rot !name ; \ Print Directory UH 18Nov87 | Create dirbuf b/rec allot dirbuf b/rec erase | Create fcb0 b/fcb allot fcb0 b/fcb erase | : wildchard? ( f c -- f' ) Ascii * = IF drop Ascii ? THEN ; | : (expand ( addr len -- ) false -rot bounds ?DO I c@ wildchard? dup ?dup IF I c! THEN LOOP drop ; | : expand ( fcb -- ) \ expand * to ??? dup filename 8 (expand extension 3 (expand ; : (dir ( addr len -- ) fcb0 !name fcb0 expand dirbuf dma! fcb0 >dosfcb search0 BEGIN dup dos-error? not WHILE $20 * dirbuf + dosfcb> tab .dosfile fcb0 >dosfcb searchnext stop? UNTIL drop ; \ File List UH 10Oct87 User file-link file-link off | : #file ( -- n ) file-link @ dup IF fileno c@ THEN 1+ ; Forth definitions : forthfiles ( -- ) file-link @ BEGIN dup WHILE cr dup .fcb @ stop? UNTIL drop ; Dos definitions \ Close a file UH 10Oct87 ' save-buffers >body $0C + @ | Alias backup | : filebuffer? ( fcb -- fcb bufaddr/flag ) prev BEGIN @ dup WHILE 2dup 2+ @ = UNTIL ; | : flushfile ( fcb -- ) \ flush file buffers BEGIN filebuffer? ?dup WHILE dup backup emptybuf REPEAT drop ; : (close ( fcb -- ) \ close file in fcb dup flushfile dup opened dup @ 0= IF 2drop exit THEN off >dosfcb closefile Abort" not found!" ; \ Create fcbs UH 10Oct87 : !files ( fcb -- ) dup isfile ! fromfile ! ; ' r@ | Alias newfcb Forth definitions : File ( -- ) Create here >r b/fcb allot newfcb b/fcb erase last @ count $1F and newfcb !name #file newfcb fileno ! file-link @ newfcb nextfile ! r> file-link ! Does> !files ; : direct 0 !files ; \ flush buffers & misc. UH 10Oct87 UH 28Nov87Dos definitions : save-files ( -- ) file-link BEGIN @ ?dup WHILE dup opened @ IF dup >dosfcb closefile drop THEN REPEAT ; ' save-files Is save-dos-buffers \ : close-files ( -- ) file-link \ BEGIN @ ?dup WHILE dup (close REPEAT ; Forth definitions : file? isfile@ .file ; \ print current file : list ( n -- ) 3 spaces file? list ; \ words for viewing UH 10Oct87 Forth definitions | $200 Constant viewoffset \ max. %512 kB files : (makeview ( -- n ) \ calc. view filed for a name blk @ dup 0= ?exit loadfile @ ?dup IF fileno @ viewoffset * + THEN ; : (view ( blk -- blk' ) \ select file and leave block dup 0=exit viewoffset u/mod file-link BEGIN @ dup WHILE 2dup fileno @ = UNTIL !files drop ; \ not found: direct access \ FORGETing files UH 10Oct87 | : remove? ( dic symb addr -- dic symb addr f ) dup heap? IF 2dup u> exit THEN 2 pick over 1+ u< ; | : remove-files ( dic symb -- dic symb ) \ flush files ! isfile@ remove? nip IF direct THEN fromfile @ remove? nip IF fromfile off THEN file-link BEGIN @ ?dup WHILE remove? IF dup (close THEN REPEAT file-link remove ; \ print a list of all buffers UH 20Oct86 : .buffers prev BEGIN @ ?dup WHILE stop? abort" stopped" cr dup u. dup 2+ @ dup 1+ IF ." Block: " over 4+ @ 5 .r ." File : " [ Dos ] .file dup 6 + @ 0< IF ." updated" THEN ELSE ." Buffer empty" drop THEN REPEAT ; \ File Interface User words UH 11Oct87 | : same ( addr -- ) >in ! ; : open isfile@ (open offset off ; : close isfile@ (close ; : assign close isfile@ !fcb open ; : make isfile@ dup !fcb (make ; | : isfile? ( addr -- addr f ) \ is adr a fcb? file-link BEGIN @ dup 0=exit 2dup body> = UNTIL drop true ; : use >in @ name find \ create a fcb if not present IF isfile? IF execute drop exit THEN THEN drop dup same File same ' execute open ; \ File Interface User words UH 25May88 : makefile >in @ File dup same ' execute same make ; : emptyfile isfile@ >dosfcb createfile ; : from isfile push use ; : loadfrom ( n -- ) isfile push fromfile push use load close ; : include 1 loadfrom ; : eof ( -- f ) isfile@ dup filesize @ swap record @ = ; : files " *.*" count (dir ; : files" Ascii " word count 2dup upper (dir ; ' files Alias dir ' files" Alias dir" \ extend Files UH 20Nov87 | : >fileend isfile@ >dosfcb size drop ; | : addblock ( n -- ) \ add block n to file dup buffer under b/blk bl fill isfile@ rec/blk over filesize +! false file-r/w IF close Abort" disk full!" THEN ; : more ( n -- ) open >fileend capacity swap bounds ?DO I addblock LOOP close open close ; : Drive: ( n -- n' ) dup Constant 1+ Does> @ drive! ; 0 Drive: a: Drive: b: Drive: c: Drive: d: 5 + Drive: j: drop \ save memory-image as disk-file UH 29Nov86 Forth definitions : savefile ( from count -- ) \ filename isfile push makefile bounds ?DO I dma! isfile@ >dosfcb write-seq Abort" disk full!" b/rec +LOOP close ; \ Status UH 10OCt87 : .blk ( -- ) blk @ ?dup 0=exit dup 1 = IF cr file? THEN base push hex ." Blk " . ?cr ; ' .blk Is .status \ No newline at end of file diff --git a/8080/AmstradCPC/GRAFDEMO.SCR b/8080/AmstradCPC/GRAFDEMO.SCR new file mode 100644 index 0000000..5dcc137 --- /dev/null +++ b/8080/AmstradCPC/GRAFDEMO.SCR @@ -0,0 +1 @@ +\ Grafik Demo UH 03Dec86Dieses File enthaelt im Wesentlichen die Definitionen der Grafikdemo vom C64 und vom Atari. Start mit INCLUDE GRAFDEMO.SCR An diesem Beispiel zeigt sich, dass sich mit volksFORTH relativ leicht Programme von einem auf den anderen Rechner uebertragen lassen, auch wenn die Basis (hier das Grafik-Paket) unterschied-lich ist. Natuerlich muss auf spezielle Eigenschaften des LINE-A-Grafic Pakets des Atari verzichtet werden. (z.B. gestrichelte Linien zeichen) Ist die Basis dagegen gleich, wie z.B der Kern aller volksFORTH Systeme, ist eine Uebernahme von Programmen gar kein Problem mehr. \ Demo Loadscreen 05Sep86 \needs Graphics include grafik.scr Onlyforth Graphics also definitions \needs exorwrite include atari.scr \ Atari Grafic-Name Layer \needs 2over include double.scr 1 $0A +thru \ clear moire \ muster kaleidos boxes \ poly lines \ tri.up tri.dn 25feb86 | : yscale [ decimal ] 400 640 */ [ hex ] ; : tri.dn ( dim -- ) >r cur.x @ cur.y @ 2dup r@ yscale - swap r@ - swap 2swap 2over set 2dup r@ yscale - swap r@ + swap draw 2dup r> yscale + draw 2swap draw set ; : tri.up ( dim -- ) >r cur.x @ cur.y @ 2dup r@ yscale - 2swap 2over set 2dup r@ yscale + swap r@ + swap draw 2dup r@ yscale + swap r> - swap draw 2swap draw set ; \ diamond UH 05Sep86 : diamond ( size -- ) >r cur.x @ cur.y @ 2dup swap r@ - swap 2swap 2over set 2dup r@ yscale - draw 2dup swap r@ + swap draw 2dup r> yscale + draw 2swap draw set ; | : big.diamond exorwrite &319 0 &639 &200 &319 &399 0 &200 4 polygon ; \ some usefull definitions 05Sep86 | : center &320 &200 set ; \ | : wrap #esc con! Ascii v con! ; wrap | : logo &117 0 DO ." volksFORTH 83 " LOOP ; | : wait BEGIN pause key? UNTIL &25 0 at getkey #cr = abort" stopped" ; | : titel &21 &24 at ." *** v o l k s F O R T H *** " &22 &31 at ." Line-A Graphic " ; \ patterns example 04Sep86\\ : muster page overwrite 1 pat.mask ! $10 0 DO patterns I 2* + @ pattern ! $10 I $10 * + dup $80 $80 rectangle LOOP 6 pat.mask ! $10 0 DO patterns I 2* + @ pattern ! $110 I $10 * dup >r + $110 r> - $80 $80 rectangle LOOP 1 pat.mask ! wait ; \ kaleidoskop UH 05Sep86 | : kaleid exorwrite home center \ patterns &30 + @ pattern ! 2 0 DO $40 1 DO $140 0 DO I diamond J 2* +LOOP 2 +LOOP LOOP ; : kaleidos page big.diamond kaleid wait ; : kaleid1 page logo kaleid wait ; : diamonds $10 0 DO \ patterns I 2* + @ pattern ! page big.diamond wait LOOP ; \ polygon example 05Sep86 | : (poly ( x y -- ) 2dup >r &100 + r> &10 + 2dup >r &10 + r> &90 + 2dup >r &30 - r> &20 + 2dup >r &50 - r> &35 - 2dup >r &30 - r> &85 - 6 polygon ; \\ : poly page invtrans &10 0 DO patterns I 5 + 2* + @ pattern ! I I * &5 * I &30 * (poly LOOP &10 0 DO patterns I 5 + 2* + @ pattern ! &510 I I * &5 * - I &30 * (poly LOOP wait ; \ moire 27feb86 : moire page curoff exorwrite &640 0 DO I &399 &639 I - 0 line 3 +loop &399 0 DO &639 &398 I - 0 I line 2 +loop titel wait ; \ boxes 05Sep86 : boxes page &162 0 DO I I set I I box &639 I 2* - I set I I box I &399 I 2* - set I I box &639 I 2* - &399 I 2* - set I I box 2 +LOOP wait ; \ linien 27feb86 | : (lines ( abstand -- ) exorwrite &640 0 DO &640 0 DO I &399 J 0 line dup +LOOP dup +LOOP drop ; : lines page home curoff &45 (lines &90 (lines BEGIN &45 (lines key $FF and $0D = UNTIL &25 0 at ; \ moire punkte muster 05Sep86 : kreis.moire page &320 0 DO &199 0 DO I dup * J dup * + &300 / 1 and IF &320 J + &200 I + 1 put.pixel &320 J - &200 I + 1 put.pixel &320 J - &200 I - 1 put.pixel &320 J + &200 I - 1 put.pixel THEN 2 +LOOP LOOP wait ; \ No newline at end of file diff --git a/8080/AmstradCPC/GRAFIK.SCR b/8080/AmstradCPC/GRAFIK.SCR new file mode 100644 index 0000000..69d60ad --- /dev/null +++ b/8080/AmstradCPC/GRAFIK.SCR @@ -0,0 +1 @@ +\ Grafik UH 03Dec86 Diese File enthaelt Definitionen, die die von der Firmware der AMSTRAD-ROMS vorgegebenen Grafikmoeglichkeiten zur Verfuegung stellt. Die Namen der Worte sind an die im Schneider-Handbuch angege- benen Bezeichnungen angelehnt. Da je nach Systemkonfiguration die Schnittstelle zur Firmware anders aussieht, muss der entsprechende Systemteil geladen werden. Dies geschieht durch auskommentieren auf dem LOAD- Screen (Screen 1 von GRAFIK.SCR). Zur Zeit sind zwei Systemkonfigurationen unterstuetzt: 1) Standard 3" Laufwerk mit 38K-CP/M 2) Vortex-X Laufwerk mit 62K-CP/M Sie koennen als Beispiel fuer andere Systemteile dienen. \ Line Graphics Loadscreen UH 03Dec86 Onlyforth include vdos62kx.scr \ Vortex X-Laufwerk 62K-CP/M \ include amsdos.scr \ original Schneider 3" (Amsdos) 38K-CP/M 1 $08 +thru Onlyforth \ Calling ROM UH 29Nov86 Onlyforth Assembler also definitions Create rom IP push jumprom call IP pop ret end-code : getstart ( -- ) W inx xchg M E mov H inx M D mov xchg 'start shld ; \ Calling Operating-System UH 29Nov86Onlyforth Vocabulary OS Assembler also OS also definitions : Sys ( addr -- ) +org Constant ;code ( -- ) getstart rom call Next end-code : >Sys ( addr -- ) Sys ;code ( n -- ) getstart H pop L A mov rom call Next end-code : Sys> ( addr -- ) Sys ;code ( -- n ) getstart rom call A L mov 0 H mvi Hpush jmp end-code : >>Sys> ( addr -- ) Sys ;code ( x y -- n ) getstart H pop D pop rom call A L mov 0 H mvi Hpush jmp end-code \ Calling Operating-System UH 29Nov86 : >>Sys ( addr - ) Sys ;code ( x y -- ) getstart H pop D pop rom call Next end-code : Sys>> ( addr - ) Sys ;code ( -- x y ) getstart rom call dpush jmp end-code \ Graphic-calls UH 29Nov86Onlyforth Vocabulary Graphics OS also Graphics also definitions $BBBA Sys init $BBBD Sys reset $BBC0 >>Sys move $BBC3 >>Sys mover $BBC6 Sys>> cursor@ $BBC9 >>Sys origin $BBCC Sys>> origin@ $BBCF >>Sys width $BBD2 >>Sys heigth $BBD5 Sys>> width@ $BBD8 Sys>> heigth@ $BBDB Sys clearwindow $BBDE >Sys pen $BBE1 Sys> pen@ $BBE4 >Sys paper $BBE7 Sys> paper@ $BBEA >>Sys plot $BBED >>Sys plotr $BBF0 >>Sys> test $BBF3 >>Sys> testr $BBF6 >>Sys line $BBF9 >>Sys liner $BC59 >Sys access \ Farbwahl Graphic UH 29Nov86 Code (ink ( col1 col2 pen -- ) $BC32 +org H lxi 'start shld H pop L A mov H pop D pop IP push L B mov E C mov jumprom call IP pop Next end-code : ink ( colour -- ) dup pen@ (ink ; Code (ink@ ( pen -- col1 col2 ) $BC35 +org H lxi 'start shld H pop L A mov IP push jumprom call D pop 0 H mvi B L mov H push C L mov D IP mvx Hpush jmp end-code : ink@ ( -- col ) pen@ (ink@ drop ; \ Randfarben UH 29Nov86 Code border ( colour -- ) $BC38 +org H lxi 'start shld H pop IP push L B mov L C mov jumprom call IP pop Next end-code Code border@ ( -- colour ) $BC3B +org H lxi 'start shld IP push jumprom call 0 H mvi C L mov IP pop Hpush jmp end-code \ Schneider Farben 05Sep86\\ 0 Constant schwarz &13 Constant weiss 1 Constant blau &14 Constant pastellblau 2 Constant hellblau &15 Constant orange 3 Constant rot &16 Constant rosa 4 Constant magenta &17 Constant pastellmagenta 5 Constant hellviolett &18 Constant hellgruen 6 Constant hellrot &19 Constant seegruen 7 Constant purpur &20 Constant hellesblaugruen 8 Constant hellmagenta &21 Constant limonengruen 9 Constant gruen &22 Constant pastellgruen &10 Constant blaugruen &23 Constant pastellblaugruen &11 Constant himmelblau &24 Constant hellgelb &12 Constant gelb &25 Constant pastellgelb &26 Constant leuchtendweiss \ polygon box rectangle UH 29Nov86 : polygon ( x1 y1 x2 y2 ... xn yn n -- ) -rot 2dup >r >r move 1 DO line LOOP r> r> line ; : box ( width heigth -- ) 0 over liner over 0 liner 0 swap negate liner negate 0 liner ; : rectangle ( x1 y1 width heigth -- ) 2swap move box ; \ No newline at end of file diff --git a/8080/AmstradCPC/HASHCASH.SCR b/8080/AmstradCPC/HASHCASH.SCR new file mode 100644 index 0000000..a456b88 --- /dev/null +++ b/8080/AmstradCPC/HASHCASH.SCR @@ -0,0 +1 @@ +\ HashCash Suchalgorithmus UH 11Nov86 Ein Algorithmus, der die Dictionarysuche beschleunigt: Zuerst wird uebr das gesucht Wort gehasht und in in einer Tabelle nachgesehen. Schlaegt der Versuch fehl, wird ganz normalgesucht. Suchzeit geht auf ca. 70-80% gegenueber normalem Suchenherunter. Hinzu kommen die Worte: cash, hash-thread, erase-cash, 'cash, und found? Im Kernal neudefiniert oder gepatched werden muessen: (find, hide, reveal, forget-words (find und (forget benutzen jejweils die alten Worte. Sie muessenumbenannt oder in die neuen Worte eingebettet werden. \ Hash Cash fuer volksFORTH UH 11Nov86 Create cash $200 allot ' Forth >body Constant hash-thread : erase-cash ( -- ) cash $200 erase ; erase-cash 1 3 +thru patch (find ( patch forget-words ) ' forget-words \ forget-words dup ' clear >body 6 + ! \ liegt auf einer ungluecklichen dup ' (forget >body $12 + ! \ Adresse, sodass das automa- dup ' empty >body 8 + ! \ tische Patchen nicht klappt. ' save >body 4+ ! patch hide patch reveal forget (patch save \ 'cash found? hfind UH 23Oct86 : 'cash ( nfa -- 'cash ) count $1F and under bounds ?DO I c@ + LOOP $FF and 2* cash + ; : found? ( str nfa -- f ) count rot count rot over = IF swap -text 0= exit THEN drop 2drop false ; : (find ( str thread -- str false | nfa true ) dup hash-thread - IF (find exit THEN drop dup 'cash @ 2dup found? IF nip true exit THEN drop hash-thread (find dup 0= ?exit over dup 'cash ! ; \ Kernal changes UH 23Oct86 ' hide >body @ | Alias last? : hide last? IF 0 over 'cash ! 2- @ current @ ! THEN ; : reveal last? IF dup dup 'cash ! 2- current @ ! THEN ; ' clear >body 6 + @ | Alias forget-words | : forget-words erase-cash forget-words ; : .cash cash $200 bounds DO I @ ?dup IF .name THEN 2 +LOOP ; \ patching UH 23Oct86 : (patch ( new old -- ) ['] cash 0 DO i @ over = IF cr I u. over I ! THEN LOOP 2drop ; : patch \ name >in @ ' swap >in ! dup >name 2- context push context ! ' (patch ; \ No newline at end of file diff --git a/8080/AmstradCPC/INSTALL.SCR b/8080/AmstradCPC/INSTALL.SCR new file mode 100644 index 0000000..95552da --- /dev/null +++ b/8080/AmstradCPC/INSTALL.SCR @@ -0,0 +1 @@ +\\ Install Editor Dieses File enthaelt einen Installer fuer den Editor. Es werden nacheinander die Tasten erfragt, die einen bestimmten Befehl ausloesen sollen. Damit ist es moeglich, die Tastatur an die individuellen Beduerfnisse anzupassen. \ install Editor UH 17Nov86 Onlyforth Editor also save warning on : tab &20 col &20 mod - spaces ; : .key ( c -- ) dup $7E > IF ." $" u. exit THEN dup bl < IF ." ^" [ Ascii A 1- ] Literal + THEN emit ; : install \ install editor's keyboard page ." Entsprechende Tasten druecken. (Blank uebernimmt.)" #keys 0 ?DO cr I 2* actiontable + @ >name .name tab ." : " I keytable + dup c@ .key tab ." -> " key dup bl = IF drop dup c@ THEN dup .key swap c! LOOP ; --> \ define action-names UH 28Nov86: :a ( addr -- adr' ) dup @ Alias 2+ ; actiontable :a up :a left :a down :a right :a push-line :a push-char :a pull-line :a pull-char :a copy-line :a copy-char :a backspace :a backspace :a backspace :a delete-char :a insert-char :a delete-line :a insert-line :a insert-on :a overwrite-on :a erase-line :a clear-to-right :a new-line :a +tab :a -tab :a home :a to-end :a search :a undo :a update-exit :a flushed-exit :a showload :a shadow-screen :a next-Screen :a back-Screen :a alter-Screen :a mark-screen drop warning off install empty UH 17Nov86 \ No newline at end of file diff --git a/8080/AmstradCPC/KERNEL.COM b/8080/AmstradCPC/KERNEL.COM new file mode 100644 index 0000000000000000000000000000000000000000..c97e1371bdf18fb23b30475f03e0829683a62655 GIT binary patch literal 13440 zcmbt5d3;pW)i39*GudV`Stf6?%#vlYOm>S1Bur)|WXvQp%tE9@kYy5sfnX9uNJ6XD zQY%>NQr8xRPb^j23KA+Vg`|K$LkWtlw%Se+tc?W|Y^~ao@0|A%iw#VGpxx(Bt-@K;#wy3$M)@-A?#axSx-RATsyZh1%4 zTu@bG?p?QhWfc2%b$4`|S9Y&o+h^|ExGrj5*<-f%M0@*|_w<>~bFNVMuR=J}cw2YZ zExir?V7Sq7ZMC^4dRv*fy6oDD8_!7T)SO#2+-yd** z0QZ344|*4PTPEa$H~}642vxM1Bms5;1hJ$Q-~|A8pv{yZzq%%q(y$0!{=>j zYBL!H(6VfV#*jsjSvC}y?_ezqGkc^IM93$ArIw9-j&m2`Yls?{-^>>KKxy_+-Et!v zvm(F&5=2-w7?{77MGhc>1npF}Y(@kG5W;QjowdRHScOGBCA~A?E$p4a+GnU6GTnyI zGl;E$AF&Xe|LQbY1?^++4!VQ>z-fZo2vxy+gXKIoc*B1oXp61k3jB|(5NT=ggs?>e zpRs%$VI^^~fqlb&VU?a7CsfQMXdXe2D^M+Da-!!3k1G=P%;91q)u4rPP7HX0C@#&- zTx_$gy&IwN;N-wHe<>GRTfpFgu8xSu6zQe`M{~s=fi>Fm4z>l~%%S%MX)}z#a%0boq!(8l~&4xI!GglB_ z#|F#$DyD53JrRD(L5by4qJP&0+ve}m7>V#Vjw8m!^D(6gJQr$p24p^V7AKYjdY*Mh z0!4i6oKm&$TpiYD^Td?-JOPuTg6BxYTlg`=DnWpUXM_ImQmmg<>Wg@`#T!`5$Ho-= zcAk&4xIMvdAb>jPU_H+{u*dxfID3xPs)H>&7x228cJi^J+0*ON!Q(s^^!t26av{H! zeVQ*}3;AquCz~wRBt4g`;TcW`KjV2MML1irRmC7IBY%LcNxCCh#cmMxa15u1(>z~A z>(vT0vV~`6Z|-R=+1$GXRpHqPw1-8W>{(%r1 zDDN07Czt{56XF~{7RF+O4|Wec-l2eY2ttczfivtmD8x!e9uZPupCGzb(3?o{kq4L6 zGLN^`GC%CDWuEN7X{N$a0o)~@2o`~vz4TVwqIHL2nd7m+d%6d{({Tt9(%>TjDogZY z%!WgxfmVd7l3c8*Rig;iC1q4q>xClJl+=nbJ;%_x8?huPr8Jl&LZxG|h!Z0^L8Rm8 zz?xdU3Hv#2L+pP|QNMKP7P)XR;+c@Arqbb?BH!Tjg|Nmj>99?Vt58c%h;fw@avZ{* z5#y>RWWdtT#JK7SnZ?q}VqDFH%wcIn1P3A#sZkO9Eq@eawNo2xBD`Eg>Qe#V zD8sRe9+seD?rteoq~d164g}O5kYWS- zzvz;^MOzPsh@PuYTNW(>%oi_~PSTxkPHRH&ZEa)S!x8)%f zTsLy3CJXM>u!#9Aftn=+vK=AbmX}osA!Wmh8o_fz*wf3LIwINdwuW;f@X|DJxj&hFMT_lLIIfNJenL&8OcirMC(sIi)y7>f#S<|) z!I!k*%$@82%Wy;TPS(eFv4gyk-z60C1FR8sZc6-C<(KrYktc1+aN$gbq0f-q7{7y~ zb5@mv)lw#I|^=o_kde*P(Ti+91MV+nOX{9Tb z6Sxz2vhK-sV>znx@vp)j&WBTxaS9BV2N2KKHamk&LvmEN9Zw^{UWpeAOQ`oY49QcXMf-6F#kz|9Hn zaHFSXNdALnw|Gs$MVw9n^e4DIr~!v$0!@h`VjKC3@u!s@_a}JjJ?Iw>$(n?{3gm?Z zPiv#shxmIDf3K+0pAs)mNq82A;o@#UuwTuQSiP{TOG|(>-8iJmH#~D_;p3sTf z_Y$b#^8`<%CG16oMraoTv5j9 zUnFLpWbpSO{U#3oJn@(vzLUsCnu~vvI2JqX9vpox@m$C4Zu}X$UUQO(bSW0D2#zK~ zb1}IN&q^e|7A?oTj*>ui;?C>BPWB;TD?6IFQ)wGR4i>@3iE-FxG?AQ(BCsSuRq@x7 zVnuj#il7{8&j*kAcH*lJPBo$VgHoPo}Ov52^ znu=jwk`QSwZ}z+IPP(b{(Ae4W!S4?|dU{>bKy-DwbY^r}(%89M@Vm9`(DFlPuty1O zO5&9cs`v8;jZc}l#0>HcxQx4!4zRS4R9uLUw`da>@_4AFRXl|UrWBq};%Gc_j7Bv( z*_VoC9u1=3UL`HQtqcQ>S$a92$$={^IdRlQ-K^ z4DloPCKoROMHM?>W3r$i*1m8BQ&TdI{}KO<yrYQJw(CN4a zug_PmQ|5{UaO`?ruPuILmTqRIu~t z)opS4n*)jt*r~X~TiG2PX~Rl5q~mO1Z$0VeN_bDl)hd<0>;5b1{eJ=~;jcQj*4v^E zv_Q|+`hvCj0o?&k_3?Qv0Z{Q{URhzI~zxkEn?RwmZSM}BK9AdbfEpPuP#&HGXeZ&~m zi{+tk(A%=$OFeqgK4P4Z7E@vP_E4VH@<=Hp-FE9Vy<^EG|o0lD{ zfz%Wc8@*wtZ(hpSXkH2hD>YD=!bbua2QEw*3&m2?&^j;0wqDyvB;^`dkiy$r{XzHI z6jjvY$BO;>%<;41=kRyq!`-((*>U=@6n0~kUw?a5KtC2cGjcM;=58h_dp-ph_LC6@eAuO(7gK}?%wod2f|OJ*sOkitp8#ErY9Gin-(_;N5{_HYQy%)6nTRU zPu97VubF39Itx~%NIt*Qjk2xeD`vsv6d~k~1nER9#?6?e=n)NCYp*@I;5^%-|3KNh zS&(etXh}n|(a@E`aI@fA10Qe(N%+w*Ff?Q5&-FfZ9d@#B>9?XIK`z8jHYV*7n)Q>o z{jDQpD?JdP01PAfYI%ylMK22*TS#?O07e(L9#A1knK;#qa@(zxE5lDJMGwV z%s`bd4TrFd4oB*Ftj`81^)7pv(rVPrcM!ywI!u5Qx}0g0;#8-d2p26h6yi~w4RccK z%Vr>IA784oZAd0&ye@p0mzJz9eKssjt#8AIpj7`A^B~1!`!TY!%Q+t8}@G6d*XI+D^3ol$+Yobq;{lnX$HwbQ%Pb@ zv0JcF1>T!RhM2ZUt-qOiQtC)6OoQ|@W^7E${a`e}7w zOc&IN;9AmW@#Hnf)sda&m{ASG&4;JcIiE8Wro)25oKA<9z{BZWqt}faH=0gUh>AP7 z3#J_$iO_s_CtV177I{d5s9B56Up4+C{TSvfBf*fD{N<^1+C7!XAm7GC(7EVB))5&) zhQ{06>~VV)2{B0X^D_uMFGE8A8MUknrNJP5lb}urXJ}pM;sx<&yP7s;=p{u)(ajsD zB%%{mX9$goT^y2sj8dk0=_PEoScuX_+T+K_#l7OwJhk-0JINa|?f`-j@$Y7!p>+n- zt_DdU+vtR&89YI83r}V=vB}6Ta-Gx&ppbts<75VfFefvJ;<5Bej@F7=WI9QE$UwTi z9^T6k>~max;^j`37@Q;1p!Hxg9(MaZp;}T3rAC7^`jqa3PH$v57tA&CbvU$}cEts) z#<+nYd6|)7n$zMkBXxH{)ab@NKxdvR{YKmk?}F*tcZ?0li!0S17{yj+um!D_y30RP zDA81C*WSt|b`C8SSq@n*)h=wbRnI#+*Dc1XbCK)n`xsNXt&a5gP@~B+3im4Ov39j3=%I zPvWXfWplKek0PoAvB4^O+tf%;KRi+w4H^RSUAu@ds3wbj#vq3OOQ(IB-Bu09p zJxJbwoBtm<|EYnjY2Qu!P;`U;O5WFUId%aGyaH}#& zRPk8Pa5aIU7_}cmP!TmMN|d0SupxPi7_;&#dzSa!Ohc?T@orCpI>wavr0L3X#xdva zh38GM2ybEh|KZGf;e<&6n{Vie484by&OocqHkhYO(+2Umr!+GIT z6Ni~djBQWhCZI8TO#0HAw&==Ll^Ji6R^Fnp;W8rZ6;GKamA#_A#w;%E58*^$^a|;x&u29?dFwzAD>^^-&!O?l%11!<8CG^+wuy>TzopuiQpGn#C}gcrAB5 z?99R}xIavQ>&jltx*qmrasCz`k~?MkM0_5CdX>p6s5vT2#>2_ci< z9%y)E9b7iDKirUhP5<}xH>CPo~~T!t#E2@KghdVsVY zr%ZE^ZS83LE@&OuwAwedel410+Xa&YM{I&Q**v+6)6{7550{?Ae4$0FW8N#J^!zfp z&n9ZmPmyJzW7o!QWd->F8rdrc?=*&yXin5~*otX?v^Z+zbyWAw(2>pCao+B?vtwh2 z<@33IgQ6<-4gW3skcrYTs82SZ&wcs$m)WtA_p{H~oE(2VB}ab!cw){NL2QPRsq8UK za$|@dky_x_*%R4Vim99T zQO%G?(gN8zafPa9m%x3A_M2esImebvM{YL`$*XfHWNU#qPKS3SK4+nE3yjN(T#N|QLshj|u z&k+=FJ$TTRmm7f3ax@sdd4hqU2hYS}^PPsD<|J@TF1c^C9eFvV#YPIUXl|X7e56e}q1&HJGgJHTv!J9shDt8Jue0OkKJ|c4rIX{6 zI<3A@TgxKueV;g9LYgVr-MO-_vwJOGT`QV^;X?31u283VI7`f^`7jR4M0HE|rh^X- zJU+a^JbDX=W{hj8QBoRXn_hi)n|XMfx&O7(4#0LI9UoHkOLWb;zKxh*g@9QsqnIcX zI%v8dC`G$dnRghTHGeA*2{jT!D3wLQ|5kRNc`Hjv(l8t{^O!oOoWbe*H_RHt8|FXb z?_%_3$)hE2b}@dUc8y^V_o6uk?MxW{WaiW^vrx>oi+{oSMj+L~WAcs&QDE30m@EV> zvT)(XU_^2H`F3RL1+B^Q0v>*9tivw<*;;v}wawykIM873#!!D!3He`C2HIp1P^$#O zxTHPk2X>(cxJ#(Vq*4SPu%H1@T1r^*5h*cEEsNj`s~&(vrpA$z3OAZX zoE2JGbN4MZ4jN$*9JL54?m^R-Wf6R8;q40}UhMgA%eV9?DD?kCpoB<5%0;hSqZTSw+l_I+Zl9w%awF!PTU7@RJbq325gQ z!3ry{)P`h#{)UWOtU+r95^057t!&7JuLR-r zNh!#e&BK_lG>!Oei(!rp>U|TknOO|WZ9FD}D7VmVE5?|5F?87k1%jt@JLZrjrq8Ad z&yf6*jy$Qa!)6=T==YKQijUYPxkqd$5_sUh4o}-)u5Czu#P*1dPVm>^fDLRYPlW>E zJYplKp1>z;TuAYxDQF`9!trDDw!RL3w#8w03S*Ziw_y~D>D1e&F+}osDjEb8@e8C& zhRZffsL)sx;aCE;Jl0)?rtdy}ke|@}(q_+V<3F;UvbAA&@(hyNC2X-#4qypfn+Jqw zF9ug{;p5cNqa{^T-!m0$cLpus*8Us&sfX4by)se9_RChQ0Pf` za#FbvzL5EzmHJ-F+m1Q@JUl-a(1v&5gb040{et$xy!@mFOk^y;rO`gs-~w-i&+{~R z`$eMQ@+{1+)mGtc6x(erqZb%Af-4{MLg*P%d3io678hRFkTq>$$&w0qDRCatmgFc& zOlLk>oF>#{w52z~ntXhwG1H|lpX@@c1Rs^qRTbIx&*=flAslBZ{3u`WhA5HMX3AO$ z$MU5HR0nEei(!_+Z}T}cZj0zp(Pt_AC7-V^ua7iL$P%{{K38hKCcJOP>nyXGJcXBs z%L;6pf1!N8qI@5S9a{!sfnay}gPyv11xh+kpEMK59*UhioH<@Rkw2PIFdQuy8zT*W zZsaelHLZYV`_l031v9xf6=l3Qt$^}!@&*%j8^>oICDw`jktGEypsGN!yS4F zlbV9oth>iz#)nqj_$H|jP0p_!=$5Y*C}|R$lqjwem#@IrP-OI0z+(mCboYa%|3P~1 z6tKZ^3;{1x6Z;#`k)iY8XDGg=gos63%}ijT;{*Hzt%Tu2uZ&#Vr?Gvzc(K5u)uSR6 zHuQA%Ma^dmMD6dV<|>`1#Hnwr#nR#!=ZSLG*&4iy)#8=rXl%azA7mx7>1G4sOD`f+P_X+ z%J0LrO9h05UKl$|IDiIHC4K-+$R2JdOOv>i|7^ZWNevQ{(6-MogD%EaLAVfa0C0PU zj)b2${JAB(NL;~*VyvjE(<|C8DWRWyqJ3MOF(F-$& z+aGeMl+Y{qd38IyWKU2Urh#~^gIxJXp&I;N!X5i`>Zo1iKs$`u6O~<>A)#W^NQAFN zzAVF4P9kTCW9{&Top10dp2i>S+9HPQfZ`(F=WX_e>5)bU%q`*@@NQIzu{z-TqIe~S zoLOnG2y;)k)w_haf^2aG=Gx*4UKfHzlN`0sSTr)p(8YW@`yFsYkrr<#Jy#QO7sVCq z!p8&_Z5cz|E)}Q(LFHZOm`W%XbiYY;@(%XkAT$J#dt8~&SBoW__9FTwH8hDkM&k8} z=tkHc?lW8=A@SyA?(M z084#H0(0aQO2AXb9AGIK@a_~rO~n?iksXzHpzu1>3mz-QixNNOH-G0KQ@Xo!cPS~XE_kh!t#hH_*y8vw zZ>wbG$Wl|Xp^$${mn|ykg*NU3MfElzo7TW@OGWju=yZk&^A8^=99#pEgY)1i|E!c* z12zY^f}fSb8Yp*g;l%;ZXQkMAwu8l23!jw=Yrx~+0?q{pmev41W_4mW?HXuvu+DJZ zXQc^ipxuE_16zmWE(iIbYv5J~>+)kBy30WU?SIX2;;K2`;SiK3tY1xWVtR_tJJ=@A z;wKz9!y^t3i*-*paE@aR0dGn$bNhq?M|#hJ&x8UVSNI8suoj>1av>!FJ|(`MMaF3@ zeD27jgvn^uT1Y6%SMny$VL78LU&&o`XRifYSstZ@auHl!R&rIE#FE_&;|{5i65meM z*C&yPx9-o)x6ZC^Et?XpC=@&j#guqI?9W|e-H;KqrsR^p-VMGoz7W}f(K$)`521-w zB>~eNlr9WBpxKI-ZwJ_S@WIX1H>8)c;)|<_zE}2PRx5e~#w|7-PtIV6 zM^ry7D^86gpGlt(msCd%N8<3Mvbcw5z~oV>!RYwsdhLumGmgGh?MPJxV|g*(TFIc7 zbt}AIhVPk`70xM-yRmHK@(c-gGtwSco}q5~#c*?Z|I7I0ZY~y>GRE3aq-QQ>TGQk7 z%)c_N>Qu&W>cqECBV1f8ruanaFBiB`I09OS^{f6YC3KH}UuowY|hWb?j z+zz@5)>e<+xWwEJ{aAJdC*(vdZ^5z;{ZcKKAFSYPo{(!oHeqEuR>IEu30Z@c=dpr^ zZbJSBR$j(RJyk@k9Krq#*gpZwZ&siHv{;7ZqvA~!40k*Hv4XeL`Jh;1uUJ%Z5*Be*JAykr=Xw^f|4cnm)TYei}}<01JD1hm`ESI{pt+=30L9%$t4cn~+j zw<@`?H-NV}6cl1MO;@ah8^p(r@NgwLw)kvgvC+{~d1K|1l|7aBL!odl&W%*OmFuab zE5}W+r&7cL)tj3;D(G@fU`|$^XAfRg-lmij(5$s%9;DAku}HCl{Kp2o+BD)-SF%Fu z4@gVZ9vHnMCWc5DaFfX;^Y&}UdCcZtP>kRvuvbaQwR%711730DRsOT$d}UP?!}UYB z3S$nuTbq!-$@IgTD*D@ia(pX6G7uHf4|rNA;Gu5GO%+cnL%va^aryiq%;%~Nx|xPQRdMcS zCrXAvl2sC)S8+I>`2?{vDMaI|38LUw2{HivRiZn%h;qXRP0iKe%oSY&kX?=U(GAXs z4`(#5`V;YmD!Qa^x6y^FqQ9be;r@Y+8u0QBU5nG`;r$suZ&t;u8JMVBzP_u^+)jx^ z%G|Z%A8o9%%&Vq!-vGF(6P5Wpt{P$o_mGgly-@Wr_Rn0od~IQ$d1Y63ZNLgl+-{p}d;2WB8-K38y>M?6uuycV`dUcKqqR#q9N)d)Kd9r-V-yGrbnSyDC4) z$N!;vyAlX>;mzqzwvA6Nn5}KsUWa)urg|2-M_MMOT7!<2j>)T5yk=pG=+{y<_^Y0~ zk=i7;zKTL}HKN!IA682Ne<dyJ|@KX(z~2Anm_Ppl@HY5k;DWa5LOq z!QfKkk zWL5N$HmhyHZ1IHbfIhfb!#7g$a6&G{+P`afw^}Q~+B-FpVgd1QVCaUjmf2tatK=i) zRYixd6MwbeTvWN?SEIWRkDfbx#5wx&!=p7v_S;h~Yp>P3t^Ip#B|;{SR1o}zBcm@L g8U2V5tFAvXI(GC|e>$T7?%^}ny>WE^Fq|0uU%DQAlK=n! literal 0 HcmV?d00001 diff --git a/8080/AmstradCPC/MATHE.SCR b/8080/AmstradCPC/MATHE.SCR new file mode 100644 index 0000000..e33ab02 --- /dev/null +++ b/8080/AmstradCPC/MATHE.SCR @@ -0,0 +1 @@ +\ Mathematics calculating sin & cos nach FD IV 1 6UH 03Dec86 Dieses File enthaelt Definitionen zur Berechnung von Integer-Sinus und -Cosinus. Sie werden z.B. von der Turtle-Grafik benutzt. \ Mathematics calculating sin & cos nach FD IV 1 6 05Sep86 Create sintab decimal 0000 , 0175 , 0349 , 0523 , 0698 , 0872 , 1045 , 1219 , 1392 , 1564 , 1736 , 1908 , 2079 , 2250 , 2419 , 2588 , 2756 , 2924 , 3090 , 3256 , 3420 , 3584 , 3746 , 3907 , 4067 , 4226 , 4384 , 4540 , 4695 , 4848 , 5000 , 5150 , 5299 , 5446 , 5592 , 5736 , 5878 , 6018 , 6157 , 6293 , 6428 , 6561 , 6691 , 6820 , 6947 , 7071 , 7193 , 7314 , 7431 , 7547 , 7660 , 7771 , 7880 , 7986 , 8090 , 8192 , 8290 , 8387 , 8480 , 8572 , 8660 , 8746 , 8829 , 8910 , 8988 , 9063 , 9135 , 9205 , 9272 , 9336 , 9397 , 9455 , 9511 , 9563 , 9613 , 9659 , 9703 , 9744 , 9781 , 9816 , 9848 , 9877 , 9903 , 9925 , 9945 , 9962 , 9976 , 9986 , 9994 , 9998 , 10000 , : sintable ( deg -- sine*10000 ) 2* sintab + @ ; --> \ sin 05Sep86 : s180 ( deg -- sine*10000 ) dup 90 > IF 180 swap - ( reflect ) THEN sintable ; : sin ( deg -- sine*10000 ) 360 mod dup 180 > IF 180 - s180 negate exit THEN s180 ; : cos ( deg -- cosine*10000 ) 90 + sin ; hex \ No newline at end of file diff --git a/8080/AmstradCPC/PORT8080.SCR b/8080/AmstradCPC/PORT8080.SCR new file mode 100644 index 0000000..c0bf563 --- /dev/null +++ b/8080/AmstradCPC/PORT8080.SCR @@ -0,0 +1 @@ +\ 8080-Portzugriff UH 11Nov86 Dieses File enthaelt Definitionen um die 8080-Ports ueber 8-Bit Adressen anzusprechen. Der Code ist leider selbstmodifizierend, da beim 8080 die Portadresse im Code ausdruecklich angegeben werden muss. Sollte dies unerwuenscht sein und ein Z80-Komputer vorliegen, kann auch das File portz80.scr benutzt werden, indem die Z80-IO-Befehle (16Bit-Adressen) benutzt werden. \ 8080-Portzugriff pc@, pc! 15Jul86 ' 0 | Alias patch Code pc@ ( addr -- c ) H pop L A mov here 4 + sta patch in 0 H mvi A L mov Hpush jmp end-code Code pc! ( c addr -- ) H pop L A Mov here 6 + sta H pop L A mov patch out Next end-code \ No newline at end of file diff --git a/8080/AmstradCPC/PORTZ80.SCR b/8080/AmstradCPC/PORTZ80.SCR new file mode 100644 index 0000000..1e11c85 --- /dev/null +++ b/8080/AmstradCPC/PORTZ80.SCR @@ -0,0 +1 @@ +\ Z80-Portzugriff UH 05Nov86 Dieses File enthaelt Definitionen um die Z80-Ports ueber 16-Bit Adressen anzusprechen. Einige Komputer, so die der Schneider Serie dekodieren ihre Ports etwas unkonventionell, sodass sie unbedingt ueber 16-Bit Adressen angesprochen werden muessen. Im allgemeinen sollte es ausreichen 8-Bit Adressen zu benutzen. \ Z80-Portaccess Extending 8080-Assembler UH 05Nov86 Assembler definitions | : Z80-io ( base -- ) \ define special Z80-io instruction Create c, Does> ( reg -- ) $ED c, c@ swap 8 * + c, ; $40 Z80-io (c)in $41 Z80-io (c)out Forth definitions --> \ store and fetch values with 16-bit port-adresses UH 05Nov86 Code pc@ ( 16b -- 8b ) \ fetch 8-bit value from 16-bit port-addr H pop IP push H B mvx L (c)in 0 H mvi IP pop hpush jmp end-code Code pc! ( 8b 16b -- ) \ store 8-bit value to 16-bit port-addr H pop D pop IP push H B mvx E (c)out IP pop Next end-code \ No newline at end of file diff --git a/8080/AmstradCPC/PRIMED.SCR b/8080/AmstradCPC/PRIMED.SCR new file mode 100644 index 0000000..e4194d3 --- /dev/null +++ b/8080/AmstradCPC/PRIMED.SCR @@ -0,0 +1 @@ +\\ Primitivst Editor zur Installation UH 17Nov86 Da zur Installationszeit der Full-Screen Editor noch nicht funtionsfaehig ist, muessen die zu aendernden Screens auf eine andere Weise ge{nder werden: mit dem primitivst Editor PRIMED, der nur ein Benutzer wort enthaelt: Benutzung: Mit "nn LIST" Screen nn zum editieren Anwaehlen, dann mit "ll NEW" den Screen aendern. Es koennen immer nur ganze Zeilen neu geschrieben werden. ll gibt an, ab welcher Zeilennummer neue Zeilen eingeben werden sollen. Die Eingabe einer leeren Zeile (nur RETURN) bewirkt den Abruch von NEW. Nach jeder Eingabe von RETURN wird die eingegebene Zeile in den Screen uebernommen, und der ganze Screen zur Kontrolle nocheinmal ausgegeben. \ primitivst Editor PRIMED UH 17Nov86 | : !line ( adr count line# -- ) scr @ block swap c/l * + dup c/l bl fill swap cmove update ; : new ( n -- ) l/s 1+ swap ?DO cr I . pad c/l expect span @ 0= IF leave THEN pad span @ I !line cr scr @ list LOOP ; \ PRIMED Demo-Screen Dieser Text entstand durch: "2 LIST 4 NEW" mit anschliessender Eingabe dieses Textes Die Kopfzeile (Zeile 0) wurde spaeter durch Verlassen von new durch Eingabe einer leeren Zeile (nur RETURN) und Neustart mit "0 NEW" erzeugt. Ulrich Hoffmann \ No newline at end of file diff --git a/8080/AmstradCPC/PRINTER.SCR b/8080/AmstradCPC/PRINTER.SCR new file mode 100644 index 0000000..b642433 --- /dev/null +++ b/8080/AmstradCPC/PRINTER.SCR @@ -0,0 +1 @@ +\\ Printer Interface 08Nov86 Dieses File enthaelt das Printer Interface zwischen volksFORTH und dem Drucker. Damit ist es moeglich Source-Texte auf bequeme Art und Weise in uebersichtlicher Form auszudrucken (6 auf eine Seite). In Verbindung mit dem Multitasker ist es moeglich, auch Texte imHintergrund drucken zu lassen und trotztdem weiterzuarbeiten. \ Printer Interface Epson RX80 18Aug86\ angepasst auf M 130i 07dec85we Onlyforth Variable shadow capacity 2/ shadow ! \ s. Editor Vocabulary Printer Printer definitions also | Variable printsem printsem off 01 +load 04 0C +thru \ M 130i - Printer \ 01 03 +thru 06 0C +thru \ Fujitsu - Printer Onlyforth \ Printer p! and controls UH 02Nov87 | : ready? ( -- f ) [ Dos ] 0 &15 biosa 0= not ; : p! ( n --) BEGIN pause stop? IF printsem unlock true abort" stopped! " THEN ready? UNTIL [ Dos ] 5 bios ; | : ctrl: ( 8b --) Create c, Does> ( --) c@ p! ; 07 ctrl: BEL 7F | ctrl: DEL 0D | ctrl: RET 1B | ctrl: ESC 0A ctrl: LF 0C ctrl: FF 0F | ctrl: (+17cpi 12 | ctrl: (-17cpi \ Printer Escapes 24dec85 | : esc: ( 8b --) Create c, does> ( --) ESC c@ p! ; Ascii 0 esc: 1/8" Ascii 1 esc: 1/10" Ascii 2 esc: 1/6" Ascii T esc: suoff Ascii N esc: +jump Ascii O esc: -jump Ascii G esc: +dark Ascii H esc: -dark \ Ascii 4 esc: +cursive Ascii 5 esc: -cursive | : ESC2 ( 8b0 8b1 --) ESC p! p! ; | : on: ( 8b --) Create c, does> ( --) ESC c@ p! 1 p! ; | : off: ( 8b --) Create c, does> ( --) ESC c@ p! 0 p! ; \ Printer Escapes 29jan86 Ascii W on: +wide Ascii W off: -wide Ascii - on: +under Ascii - off: -under Ascii S on: sub Ascii S off: super Ascii P on: (10cpi Ascii P off: (12cpi : 10cpi (-17cpi (10cpi ; : 12cpi (-17cpi (12cpi ; : 17cpi (10cpi (+17cpi ; : lines ( #.of.lines --) Ascii C ESC2 ; : "long ( inches --) 0 lines p! ; : american 0 Ascii R ESC2 ; : german 2 Ascii R ESC2 ; : normal 12cpi american suoff 1/6" 0C "long RET ; \ Printer Escapes 16Jul86 | : esc: ( 8b --) Create c, does> ( --) ESC c@ p! ; Ascii 0 esc: 1/8" Ascii 1 esc: 1/10" Ascii 2 esc: 1/6" Ascii T esc: suoff Ascii N esc: +jump Ascii O esc: -jump Ascii G esc: +dark Ascii H esc: -dark Ascii 4 esc: +cursive Ascii 5 esc: -cursive Ascii M esc: 12cpi Ascii P | esc: (-12cpi : 10cpi (-12cpi (-17cpi ; : 17cpi (-12cpi (+17cpi ; ' 10cpi Alias pica ' 12cpi Alias elite \ Printer Escapes 16Jul86 | : ESC2 ( 8b0 8b1 --) ESC p! p! ; | : on: ( 8b --) Create c, does> ( --) ESC c@ p! 1 p! ; | : off: ( 8b --) Create c, does> ( --) ESC c@ p! 0 p! ; Ascii W on: +wide Ascii W off: -wide Ascii - on: +under Ascii - off: -under Ascii S on: sub Ascii S off: super Ascii p on: +prop Ascii p off: -prop : lines ( #.of.lines --) Ascii C ESC2 ; : "long ( inches --) 0 lines p! ; : american 0 Ascii R ESC2 ; : german 2 Ascii R ESC2 ; : normal 12cpi american suoff 1/6" 0C "long RET ; \ Printer Output 04Jul86 : prinit ; \ initializing Printer | Variable pcol pcol off | Variable prow prow off | : pemit ( 8b --) p! 1 pcol +! ; | : pcr ( --) RET LF 1 prow +! pcol off ; | : pdel ( --) DEL pcol @ 1- 0 max pcol ! ; | : ppage ( --) FF prow off pcol off ; | : pat ( row col --) over prow @ < IF ppage THEN swap prow @ - 0 ?DO pcr LOOP dup pcol @ < IF RET pcol off THEN pcol @ - spaces ; | : pat? ( -- row col) prow @ pcol @ ; | : ptype ( adr len --) dup pcol +! bounds ?DO I c@ p! LOOP ; \ Printer output 28Jun86 | Output: >printer pemit pcr ptype pdel ppage pat pat? ; Forth definitions : print >printer normal ; : printable? ( char -- f) bl Ascii ~ uwithin ; \ Variables and Setup 23Oct86 Printer definitions $00 | Constant logo | Variable pageno | Create scr#s $0E allot \ enough room for 6 screens | : header ( -- ) 12cpi 4 spaces ." Page No " +dark pageno @ 2 .r $0D spaces ." volksFORTH83 der FORTH-Gesellschaft eV " 5 spaces file? -dark 1 pageno +! 17cpi ; \ Print 2 screens across on a page 03dec85 | : text? ( scr# -- f) block dup c@ printable? IF b/blk -trailing nip 0= THEN 0= ; | : pr ( scr# --) dup capacity 1- u> IF drop logo THEN 1 scr#s +! scr#s dup @ 2* + ! ; | : 2pr ( scr#1 scr#2 line# --) cr dup 2 .r space c/l * >r pad $101 bl fill swap block r@ + pad c/l cmove block r> + pad c/l + 1+ c/l cmove pad $101 -trailing type ; | : 2scr ( scr#1 scr#2 --) cr cr $1E spaces +wide +dark over 4 .r $1C spaces dup 4 .r -wide -dark cr l/s 0 DO 2dup I 2pr LOOP 2drop ; \ Printer 6 screens on a page 03dec85 | : pr-start ( --) scr#s off 1 pageno ! ; | : pagepr ( --) header scr#s off scr#s 2+ 3 0 DO dup @ over 6 + @ 2scr 2+ LOOP drop page ; | : shadowpr ( --) header scr#s off scr#s 2+ 3 0 DO dup @ over 2+ @ 2scr 4 + LOOP drop page ; | : pr-flush ( -- f) scr#s @ dup \ any screens left over? IF BEGIN scr#s @ 5 < WHILE -1 pr REPEAT logo pr THEN 0<> ; \ Printer 6 screens on a page 23Nov86Forth definitions : pthru ( first last --) printsem lock output push print pr-start 1+ swap ?DO I text? IF I pr THEN scr#s @ 6 = IF pagepr THEN LOOP pr-flush IF pagepr THEN printsem unlock ; : document ( first last --) isfile@ IF capacity 2/ shadow ! THEN printsem lock output push print pr-start 1+ swap ?DO I text? IF I pr I shadow @ + pr THEN scr#s @ 6 = IF shadowpr THEN LOOP pr-flush IF shadowpr THEN printsem unlock ; : listing ( --) 0 capacity 2/ 1- document ; \ Printerspool 03Nov86 \needs Task \\ | Input: noinput 0 false drop 2drop ; $100 $200 noinput Task spooler keyboard : spool ( from to -- ) isfile@ spooler 3 pass isfile ! pthru stop ; \ No newline at end of file diff --git a/8080/AmstradCPC/READ.ME b/8080/AmstradCPC/READ.ME new file mode 100644 index 0000000..3d9232c --- /dev/null +++ b/8080/AmstradCPC/READ.ME @@ -0,0 +1,123 @@ +[nderungen im CP/M-volksFORTH von Version 3.80 zu Version 3.80a UH 04M{r88 +============================================================================= + +Die Unvertr{glichkeit des urspr}nglichen CP/M-volksFORTHs mit CP/M+ und die +damit verbundene Vielzahl von unterschiedlichen Versionen hat eine allgmeine +]berarbeitung des CP/M-volksFORTHs notwendig gemacht. +Bei dieser Gelegenheit wurden gleich einige Fehler beseitigt und einige +neue Funktionen eingef}hrt. + +1. [nderungen im Kern (SOURCE.SCR) + + - Die Terminal-Ein- und Ausgabe wurde auf ein Mindestma~ begrenzt, + soda~ auch unmittelbar mit dem Kern gearbeitet werden kann. + Es gibt keinen Zeileneditor f}r die Eingabezeile mehr, dieser wurde + zusammen mit der "Terminal:" Funktion in das File XINOUT.SCR ausgelagert. + + - Der Kern enth{lt kein Fileinterface mehr, sondern arbeitet nur in dem + File, da~ bei Aufruf in der Kommandozeile mit angegeben wird (default- + file). Typischerweise wird mit diesem Mechanismus zuerst das + File-Interface geladen. + + - Direkter Diskettezugriff wird im Kern nicht mehr unterst}tzt, da er + unter CP/M+ nicht problemlos zu implementieren ist. Au~erdem kann + in Ermangelung eines CP/M+ Systems der Code hier nicht getestet werden. + Diskettenzugriff findet nur noch }ber das BDOS statt. + + - Zahlreiche Funktionen des Kerns wurden neu }berarbeitet und in Code + geschrieben, als wichtige neue Funktion des Kerns ist "search hinzu- + gekommen, das eine schnelle Suche mit Ber}cksichtigung der Gro~/Klein- + schreibung erm|glicht. + + - Die Funktion CAPITALIZE ist durch die {hnliche Funktion UPPER ersetzt + worden. Das EXIT in NAME verschiebt sich dadurch. + + - Der Kern gibt beim Verlassen eine Gr|~enangabe in (256 Byte)-Seiten aus. + Diese Angabe kann direkt benutzt werden, um mit dem CP/M SAVE Kommando + das System auf Diskette zu schreiben. (Forth: SAVE nicht vergessen! ) + + - SAVE-BUFFERS ist um ein defered Wort SAVE-DOS-BUFFERS erweitert worden. + Damit sollte der l{stige CP/M+ Fehler ausgeschaltet sein. + + - Das defered Wort POSTLUDE regelt die letzte Handlung des Systems vor dem + CP/M Warmstart (Cursor anschalten, Bildschirm l|schen oder Systemgr|~e + ausgeben...) + + - Die Kommandozeile des Aufrufs wird in den TIB kopiert und kann dort + interpretiert werden. Das \ffnen des default-Files l|scht allerdings den + TIB wieder, soda~ diese Funktion erst ausgenutzt werden kann, wenn das + Fileinterface geladen ist. (DRVINIT |ffnet nicht mehr das default-File.) + + - Die Interpret-Loop wurde }berarbeitet und um das Wort PROMPT erweitert. + Das Sonderwort >INTERPRET ist weggefallen. Seine Funktion uebernimmt + jetzt das (normale) defered Wort PARSER. + + - Die Kontrollstruktur-Anweisungen (IF, WHILE ... ) sind jetzt auch inter- + aktiv verwendbar. + + - Diverse kleinere [nderungen haben stattgefunden. + + +2. [nderungen im Editor (EDITOR.SCR, STRING.SCR) + + - Das Markieren der Screens wurde korrigiert und geschieht jetzt auch + beim Suchen/Ersetzen und bei showload richtig. + + - VIEW wurde ge{ndert und sucht nun nach dem in Blanks eingerahmten Wort. + + - Es wird nun zus{tzlich das Associative File angezeigt. + + - Beim Suchen/Ersetzen wird die Screennummer hochgez{hlt, um eine Kontrolle + }ber das Suchen zu geben. + + - Die Textsuche ist nun schon im Kern definiert, die elementaren String- + funktionen sind mit in das EDITOR.SCR genommen worden. STRING.SCR ist + daher entfallen. + + +3. [nderungen im Multi-Tasker (TASKER.SCR) + + - Das Wort TASK wurde ge{ndert: Die Konstante ist nun vor der Task + definiert. Man kann also nun mit FORGET tats{chlich die Task + vergessen. + + - Der PAUSE/WAKE/STOP-Mechanismus wurde ge{ndert. In der benutzung ergibt + sich daraus keine [nderung. + + +4. [nderungen im Fileinterface (FILEINT.SCR) + + - Das Fileinterface wurde }berarbeitet und einige Fehler beseitigt. + Die Namen zahlreicher Worte haben sich ge{ndert, sind dadurch aber + systematischer geworden. Die Funktionen sind im Wesentlichen gleich + geblieben. + + +5. Terminal-Installation (Zusatz zu Anpassung von volksFORTH an den Computer) + + - Da der Kern kein Fileinterface mehr enth{lt, mu~ dies noch vor + dem Primitivst-Editor geladen werden. Es ergibt sich also die Kommando- + sequenz: + A> kernel fileint.scr + 1 load + use primed.scr 1 load + use terminal.scr + + +6. Erstellen eines Standard-Systems + + - Mit folgender Kommandosequenz wird aus KERNEL.COM das File + VOLKS4TH.COM gemacht: + + A> kernel fileint.scr + 1 load + include startup.scr + +7. Neue Files auf der Diskette + + - READ.ME dieses File + - XINOUT.SCR Terminalfunktionen und Zeileneditor f}r Eingabe + - COPY.SCR Die Funktionen COPY und CONVEY (fr}her im Kern). + + - STRING.SCR Entf{llt, da in EDITOR.SCR und SOURCE.SCR integriert. + \ No newline at end of file diff --git a/8080/AmstradCPC/RELOCATE.SCR b/8080/AmstradCPC/RELOCATE.SCR new file mode 100644 index 0000000..832e6bd --- /dev/null +++ b/8080/AmstradCPC/RELOCATE.SCR @@ -0,0 +1 @@ +\\ Relocate System 11Nov86 Dieses File enthaelt das Utility-Wort BUFFERS. Mit ihm ist es moeglich die Zahl der Disk-Buffers festzulegen, die volksFORTH benutzt. Voreingestellt sind 4 Buffer. Benutzung: nn BUFFERS \ Relocate a system 16Jul86 | : relocate-tasks ( mainup -- ) up@ dup BEGIN 2+ under @ 2dup - WHILE rot drop REPEAT 2drop ! ; | : relocate ( stacklen rstacklen -- ) 2dup + b/buf + 2+ limit origin - u> abort" kills all buffers" over pad $100 + origin - u< abort" cuts the dictionary" dup udp @ $40 + u< abort" a ticket to the moon with no return ..." flush empty over + origin + origin $0A + ! \ r0 origin + dup relocate-tasks \ multitasking link 6 - origin 8 + ! \ s0 cold ; --> \ bytes.more buffers 29Jun86 | : bytes.more ( n+- -- ) up@ origin - + r0 @ up@ - relocate ; : buffers ( +n -- ) b/buf * 4+ limit r0 @ - swap - bytes.more ; \ No newline at end of file diff --git a/8080/AmstradCPC/SAVESYS.SCR b/8080/AmstradCPC/SAVESYS.SCR new file mode 100644 index 0000000..a07add8 --- /dev/null +++ b/8080/AmstradCPC/SAVESYS.SCR @@ -0,0 +1 @@ +\\ savesystem 11Nov86 Dieses File enthaelt das Utility-Wort SAVESYSTEM. Mit ihm kann man das gesamte System als File auf Disk schreiben. Achtung: Es wird SAVE ausgefuehrt, daher ist nach SAVESYSTEM der Heap geloescht! Benutzung: SAVESYSTEM \ savsystem 05Nov86 : savesystem \ filename save $100 here over - savefile ; \\ Einfaches savesystem 18Aug86 | : message ( -- ) base push decimal cr ." ready for SAVE " here 1- $100 / u. ." VOLKS4TH.COM" cr ; : savesystem ( -- ) save message bye ; \ No newline at end of file diff --git a/8080/AmstradCPC/SEE.SCR b/8080/AmstradCPC/SEE.SCR new file mode 100644 index 0000000..d91fa7d --- /dev/null +++ b/8080/AmstradCPC/SEE.SCR @@ -0,0 +1 @@ +\ Extended-Decompiler for VolksForth LOAD-SCREEN UH 07Nov86 Dieses File enthaelt einen Decompiler, der bereits kompilierte Worte wieder in Sourcetextform bringt. Strukturierte Worte wie IF THEN ELSE, BEGIN WHILE REPEAT UNTIL und DO LOOP +LOOP werden in einem an AI-grenzenden Vorgang erkannt und umgeformt. Ein Decompiler kann aber keine (Stack-) Kommentare wieder herzaubern, die Benutzung der Screens und dann view, wird daher staerkstens empfohlen. Denn: Es ist immernoch ein Fehler drin! Und um den zu korrigieren, ist der Sourcetext dem Objektkode doch vorzuziehen. Benutzung: see \ Extended-Decompiler for VolksForth LOAD-SCREEN 07Nov86 Onlyforth Tools also definitions 1 13 +thru \\ Produces compilable Forth source from normal compiled Forth. These source blocks are based on the works of Henry Laxen, Mike Perry and Wil Baden volksFORTH version: U. Hoffmann \ detacting does> 01Jul86 internal ' does> 4+ @ Alias (;code ' Forth @ 1+ @ Constant (dodoes> : does? ( IP - f ) dup c@ $CD ( call ) = swap 1+ @ (dodoes> = and ; \ indentation. 04Jul86Variable #spaces #spaces off : +in ( -- ) 3 #spaces +! ; : -in ( -- ) -3 #spaces +! ; : ind-cr ( -- ) ( col #spaces @ = ?exit ) cr #spaces @ spaces ; : ?ind-cr ( -- ) col c/l u> IF ind-cr THEN ; \ case defining words 01Jul86 : Case: ( -- ) Create: Does> swap 2* + perform ; : Associative: ( n -- ) Constant Does> ( n - index ) dup @ -rot dup @ 0 DO 2+ 2dup @ = IF 2drop drop I 0 0 LEAVE THEN LOOP 2drop ; \ branching 04Jul86 Variable #branches Variable #branch : branch-type ( n -- a ) 6 * pad + ; : branch-from ( n -- a ) branch-type 2+ ; : branch-to ( n -- a ) branch-type 4+ ; : branched ( adr type -- ) \ Make entry in branch-table. #branches @ branch-type ! dup #branches @ branch-from ! 2+ dup @ + #branches @ branch-to ! 1 #branches +! ; \\ branch-table: { type0|from0|to0 | type1|from1|to1 ... } \ branching 01Jul86 : branch-back ( adr type -- ) \ : make entry in branch-table & reclassify branch-type.) over swap branched 2+ dup dup @ + swap 2+ ( loop-start,-end.) 0 #branches @ 1- ?DO over I branch-from @ u> IF LEAVE THEN dup I branch-to @ = IF ['] while I branch-type ! THEN -1 +LOOP 2drop ; \ branching 01Jul86: forward? ( ip -- f ) 2+ @ 0> ; : ?branch+ ( ip -- ip' ) dup 4+ swap dup forward? IF ['] if branched exit THEN ['] until branch-back ; : branch+ ( ip -- ip' ) dup 4+ swap dup forward? IF ['] else branched exit THEN ['] repeat branch-back ; : (loop)+ ( ip -- ip' ) dup dup @ ( loop,+loop ) branch-back -1 #branches +! 4+ ; : string+ ( ip -- ip' ) 2+ count + even ; : (;code+ ( ip -- ip' ) 2+ dup does? not IF 0= exit THEN 3+ ; \ classify each word 25Aug86Forth &15 Associative: execution-class ] clit lit ?branch branch (do (." (abort" (;code (" (?do (loop (+loop unnest (is compile [ Case: execution-class+ 3+ 4+ ?branch+ branch+ 2+ string+ string+ (;code+ string+ 2+ 4+ 4+ 0= 4+ 4+ 2+ ; Tools \ first pass 01Jul86 : pass1 ( cfa -- ) #branches off >body BEGIN dup @ execution-class execution-class+ dup 0= stop? or UNTIL drop ; \ identify branch destinations. 04Jul86: thru.branchtable ( -- limit start ) #branches @ 0 ; : ?.then ( ip -- ) thru.branchtable ?DO I branch-to @ over = IF I branch-from @ over u< IF I branch-type @ dup ['] else = swap ['] if = or IF -in ." THEN " ind-cr LEAVE THEN THEN THEN LOOP ; : ?.begin ( ip -- ) thru.branchtable ?DO I branch-to @ over = IF I branch-from @ over u< not IF I branch-type @ dup ['] repeat = swap ['] until = or IF ind-cr ." BEGIN " +in LEAVE THEN THEN THEN LOOP ; ( put "BEGIN" and "THEN" where used.) \ decompile each type of word 01Jul86 : .word ( ip -- ip' ) dup @ >name .name 2+ ; : .(word ( ip -- ip' ) dup @ >name ?dup 0= IF ." ??? " ELSE count $1f and swap 1+ swap 1- type space THEN 2+ ; : .inline ( val16b -- ) dup >name ?dup IF ." ['] " .name drop exit THEN . ; : .lit ( ip -- ip' ) 2+ dup @ .inline 2+ ?.then ; : .clit ( ip -- ip' ) 2+ dup c@ . 1+ ?.then ; : .string ( ip -- ip' ) .(word count 2dup type Ascii " emit space + even ?.then ; : .unnest ( ip -- 0 ) ." ; " 0= ; \ decompile each type of word 01Jul86 : .default ( ip -- ip' ) dup @ >name ?dup IF c@ $40 and IF ." [COMPILE] " THEN THEN .word ?.then ; : .['] ( ip -- ip' ) .(word dup @ 2- >name .name 2+ ?.then ; : .compile ( ip -- ip' ) .word .word ?.then ; \ decompiling conditionals 04Jul86 : .if ( ip nfa -- ip' ) ind-cr .name +in 4+ ?.then ; : .repeat ( ip nfa -- ip' ) -in .name ind-cr 4+ ?.then ; : .else ( ip nfa -- ip' ) -in ind-cr .name +in 4+ ; : .do ( ip nfa -- ip' ) ind-cr .(word +in 2+ ?.then ; : .loop ( ip nfa -- ip' ) -in .(word ind-cr 2+ ?.then ; 5 Associative: branch-class ' if , ' while , ' else , ' repeat , ' until , Case: .branch-class .if .else .else .repeat .repeat ; : .branch ( ip -- ip' ) #branch @ branch-type @ 1 #branch +! dup >name swap branch-class .branch-class ; \ decompile Does> ;code 04Jul86 : .(;code ( IP - IP' f) 2+ dup does? IF ind-cr ." DOES> " 3+ ELSE ." ;CODE " 0= THEN ; \ classify word's output 01Jul86 Case: .execution-class .clit .lit .branch .branch .do .string .string .(;code .string .do .loop .loop .unnest .['] .compile .default ; \ decompile colon-definitions 04Jul86 : pass2 ( cfa -- ) #branch off >body BEGIN ?.begin ?ind-cr dup @ execution-class .execution-class dup 0= stop? or UNTIL drop ; : .pfa ( cfa -- ) #spaces off +in dup pass1 pass2 ; : .immediate ( cfa - ) >name c@ dup ?ind-cr 40 and IF ." IMMEDIATE " THEN ?ind-cr 80 and IF ." RESTRICT" THEN ; : .: ( cfa - ) ." : " dup >name .name 3 spaces .pfa ; \ display category of word 01Jul86external Defer (see internal : .does> ( cfa - ) ." DOES> " @ 1+ .pfa ; : .user-variable ( cfa - ) ." USER " dup >name dup .name 3 spaces swap execute @ u. .name ." ! " ; : .defer ( cfa - ) ." deferred " dup >name .name ." Is " >body @ (see ; : .other ( cfa - ) dup >name .name dup @ over >body = IF drop ." is Code " exit THEN dup @ does? IF .does> exit THEN drop ." is unknown " ; \ decompiling variables and constants 01Jul86 : .constant ( cfa - ) dup >body @ u. ." CONSTANT " >name .name ; : .variable ( cfa - ) ." VARIABLE " dup >name dup .name 3 spaces swap >body @ u. .name ." ! " ; \ classify a word UH 25Jan88 5 Associative: definition-class ' quit @ , ' 0 @ , ' scr @ , ' base @ , ' 'cold @ , Case: .definition-class .: .constant .variable .user-variable .defer .other ; \ Top level of Decompiler 04Jul86 external : ((see ( cfa -) #spaces off cr dup dup @ definition-class .definition-class .immediate ; ' ((see Is (see Forth definitions : see ' (see ; \ No newline at end of file diff --git a/8080/AmstradCPC/SIMPFILE.SCR b/8080/AmstradCPC/SIMPFILE.SCR new file mode 100644 index 0000000..1fd4b38 --- /dev/null +++ b/8080/AmstradCPC/SIMPFILE.SCR @@ -0,0 +1 @@ +\\ Simple Files 11Nov86 Wenn volksFORTH im Direktzugriff Disketten bearbeitet, ist es trotzdem wuenschenswert eine Art File-Struktur zu besitzen. Dieses File enthaelt eine einfache Implementation eines Filesystems. Der/die Programmierer/in muss selbst die Direktory auf dem laufenden halten: in ihr sind die Start-Bloecke des entsprechenden Diskettenteils gespeichert. Sogar eine Hierarchie von Direktories laesst sich so relisieren. Vorgestellt wurde dieses FileSystem von Georg Rehfeld und auch von ihm fuer volksFORTH implementiert (ultraFORTH auf dem C64). \ simple files 12feb86 \needs search .( search missing) \\ | Variable (dir : dir (dir @ ; : root 0 (dir ! ; root | : read" ( -- n) Ascii " word count dup >r dir block b/blk search 0= abort" not found" r> + >in push >in ! bl dir block b/blk (word number drop ; : load" read" dir + load ; : dir" read" (dir +! ; : list" read" dir + list ; \ 1 +load \ Only if file" is needed \ simple files 01feb86 | : snap ( n0 -- n1) $20 / 3 max $20 * ; : file" ( n --) Ascii " word count 2dup dir block b/blk search IF + nip ELSE drop dir block b/blk -trailing nip snap $20 + dup b/blk 1- > abort" directory full" 2dup + >r dir block + swap cmove r> THEN snap $18 + >r dir - extend under dabs <# # # # # base @ $0A = IF Ascii & ELSE Ascii $ THEN hold rot 0< IF Ascii - ELSE bl THEN hold #> r> dir block + swap cmove update ; \ dir load" 11feb86 \needs search .( search missing) \\ 0 Constant dir : load" ( -- ) Ascii " word count dup >r dir block b/blk search 0= abort" not found" r> + >in @ blk @ rot >in ! dir blk ! bl word number drop -rot blk ! >in ! load ; \ No newline at end of file diff --git a/8080/AmstradCPC/SOURCE.SCR b/8080/AmstradCPC/SOURCE.SCR new file mode 100644 index 0000000..1ee646d --- /dev/null +++ b/8080/AmstradCPC/SOURCE.SCR @@ -0,0 +1 @@ +\\ volksFORTH CP/M 2.2 rev. 3.80a 18Nov87 Entwicklung des volksFORTH-83 von K. Schleisiek, B. Pennemann, G. Rehfeld, D. Weineck, U. Hoffmann Anpassung fuer Intel 8080 und CP/M 2.2 von U. Hoffmann Dieses File enthaelt den kompletten Sourcetext des Kern-Systems fuer die Intel 8080-CPU und die Anpassung an CP/M 2.2 und CP/M+.Mit Hilfe eines Target-Compilers wird daraus das volksFORTH- System erzeugt, daher finden sich an einigen Stellen Anweisungenan den Target-Compiler, die fuer das Verstaendnis des Systems nicht wichtig sind. Version 3.80a enthaelt gegenueber 3.80 einige Aenderungen, ins- besondere die Bdos-Schnittstelle fuer Disk-IO im Kern. \ CP/M 2.2 volksForth Load Screen 27Nov87 Onlyforth $9000 displace ! Target definitions $100 here! 1 $74 +thru \ Standard 8080-System cr .( unresolved: ) .unresolved ( ' .blk is .status ) save-target KERNEL.COM \ FORTH Preamble and ID 04Oct87 Assembler nop 0 jmp here 2- >label >boot nop 0 jmp here 2- >label >cold nop 0 jmp here 2- >label >restart here dup origin! \ Hier beginnen die Kaltstartwerte der Benutzervariablen 6 rst 0 jmp end-code \ for multitasker $100 allot | Create logo ," volksFORTH-83 rev. 3.80a" \ Assembler Labels Next Forth-Register 29Jun86 Label dpush D push Label hpush H push Label >next IP ldax IP inx A L mov IP ldax IP inx A H mov Label >next1 M E mov H inx M D mov xchg pchl end-code Variable RP Variable UP \ IP in BC \ W in DE \ SP in SP Variable IPsave \ Assembler Macros 20Oct86Compiler Assembler also definitions Forth : Next T >next jmp [ Forth ] ; T hpush Forth Constant hpush T dpush Forth Constant dpush T >next Forth Constant >next : rpush ( reg -- ) RP lhld H dcx DUP M mov ( high ) H dcx 1+ M mov ( low ) RP shld [ Forth ] ; : rpop ( reg -- ) RP lhld M over 1+ mov ( low ) H inx M swap mov ( high ) H inx RP shld [ Forth ] ; \ rpush und rpop gehen nicht mit HL : mvx ( src dest -- ) 2dup mov ( high ) 1+ swap 1+ swap mov ( low ) [ Forth ] ; Target \ recover ;c: noop 20Oct86 Create recover Assembler W pop IP rpush W IP mvx Next end-code Compiler Assembler also definitions Forth : ;c: 0 T recover call end-code ] [ Forth ] ; Target | Code di di Next end-code | Code ei ei Next end-code Code noop >next here 2- ! end-code \ User variables 04Oct87 Constant origin 8 uallot drop \ Multitasker \ Felder: entry link spare SPsave \ Laenge kompatibel zum 68000 und 6502 volksFORTH User s0 User r0 User dp User offset 0 offset ! User base $0A base ! User output User input User errorhandler \ pointer for Abort" -code User voc-link User udp \ points to next free addr in User \ manipulate system pointers 11Jun86 Code sp@ ( -- addr) 0 H lxi SP dad hpush jmp end-code Code sp! ( addr --) H pop sphl Next end-code Code up@ ( -- addr) UP lhld hpush jmp end-code Code up! ( addr --) H pop UP shld Next end-code \ manipulate returnstack 11Jun86 Code rp@ ( -- addr ) RP lhld hpush jmp end-code Code rp! ( addr -- ) H pop RP shld Next end-code Code >r ( 16b -- ) D pop D rpush Next end-code restrict Code r> ( -- 16b ) D rpop D push Next end-code restrict \ r@ rdrop exit unnest ?exit 07Oct87Code r@ ( -- 16b ) RP lhld M E mov H inx M D mov D push Next end-code Code rdrop RP lhld H inx H inx RP shld Next end-code restrict Code exit Label >exit IP rpop Next end-code Code unnest >exit here 2- ! Code ?exit ( flag -- ) H pop H A mov L ora >exit jnz Next end-code Code 0=exit ( flag -- ) H pop H A mov L ora >exit jz Next end-code \ : ?exit ( flag -- ) IF rdrop THEN ; \ execute perform 11Jun86 18Nov87 Code execute ( cfa -- ) H pop >Next1 jmp end-code Code perform ( 'cfa -- ) H pop M A mov H inx M H mov A L mov >Next1 jmp end-code \\ : perform ( addr -- ) @ execute ; \ c@ c! ctoggle 07Oct87 Code c@ ( addr -- 8b ) H pop M L mov 0 H mvi hpush jmp end-code Code c! ( 16b addr -- ) H pop D pop E M mov Next end-code Code flip ( 16b1 -- 16b2 ) H pop H A mov L H mov A L mov Hpush jmp end-code Code ctoggle ( 8b addr -- ) H pop D pop M A mov E xra A M mov Next end-code \\ : ctoggle ( 8b addr --) under c@ xor swap c! ; \ @ ! 2@ 2! 11Jun86 18Nov87 Code @ ( addr -- 16b ) H pop Label fetch M E mov H inx M D mov D push Next end-code Code ! ( 16b addr -- ) H pop D pop E M mov H inx D M mov Next end-code Code 2@ ( addr -- 32b ) H pop H push H inx H inx M E mov H inx M D mov H pop D push M E mov H inx M D mov D push Next end-code Code 2! ( 32b addr -- ) H pop D pop E M mov H inx D M mov H inx D pop E M mov H inx D M mov Next end-code \ +! drop swap 11Jun86 18Nov87 Code +! ( 16b addr -- ) H pop Label +store D pop M A mov E add A M mov H inx M A mov D adc A M mov Next end-code \ : +! ( n addr -- ) under @ + swap ! ; Code drop ( 16b -- ) H pop Next end-code Code swap ( 16b1 16b2 -- 16b2 16b1 ) H pop xthl hpush jmp end-code \ dup ?dup 16May86 Code dup ( 16b -- 16b 16b ) H pop H push hpush jmp end-code Code ?dup ( 16b -- 16b 16b / false) H pop H A mov L ora 0<> ?[ H push ]? hpush jmp end-code \\ : ?dup ( 16b -- 16b 16b / false) dup IF dup THEN ; : dup ( 16b -- 16b 16b ) sp@ @ ; \ over rot nip under 11Jun86 Code over ( 16b1 16b2 - 16b1 16b2 16b1 ) D pop H pop H push dpush jmp end-code Code rot ( 16b1 16b2 16b3 - 16b2 16b3 16b1 ) D pop H pop xthl dpush jmp end-code Code nip ( 16b1 16b2 -- 16b2) H pop D pop hpush jmp end-code Code under ( 16b1 16b2 -- 16b2 16b1 16b2) H pop D pop H push dpush jmp end-code \\ : over >r swap r> swap ; : rot >r dup r> swap ; : nip swap drop ; : under swap over ; \ -rot pick roll -roll 11Jun86Code -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) H pop D pop xthl H push D push Next end-code Code pick ( n -- 16b.n ) H pop H dad SP dad M E mov H inx M D mov D push Next end-code : roll ( n -- ) dup >r pick sp@ dup 2+ r> 1+ 2* cmove> drop ; : -roll ( n -- ) >r dup sp@ dup 2+ dup 2+ swap r@ 2* cmove r> 1+ 2* + ! ; \\ : -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) rot rot ; : pick ( n -- 16b.n ) 1+ 2* sp@ + @ ; \ double word stack manipulation 09May86Code 2swap ( 32b1 32b2 -- 32b2 32b1) H pop D pop xthl H push 5 H lxi SP dad M A mov D M mov A D mov H dcx M A mov E M mov A E mov H pop dpush jmp end-code Code 2drop ( 32b -- ) H pop H pop Next end-code Code 2dup ( 32b -- 32b 32b) H pop D pop D push H push dpush jmp end-code \\ : 2swap ( 32b1 32b2 -- 32b2 32b1) rot >r rot r> ; : 2drop ( 32b -- ) drop drop ; : 2dup ( 32b -- 32b 32b) over over ; \ + and or xor not 09May86Code + ( n1 n2 -- n3 ) H pop D pop D dad hpush jmp end-code Code or ( 16b1 16b2 -- 16b3 ) H pop D pop H A mov D ora A H mov L A mov E ora A L mov hpush jmp end-code Code and ( 16b1 16b2 -- 16b3 ) H pop D pop H A mov D ana A H mov L A mov E ana A L mov hpush jmp end-code Code xor ( 16b1 16b2 -- 16b3 ) H pop D pop H A mov D xra A H mov L A mov E xra A L mov hpush jmp end-code Code not ( 16b1 -- 16b2 ) H pop Label >not H A mov cma A H mov L A mov cma A L mov hpush jmp end-code \ - negate 16May86 Code - ( n1 n2 -- n3 ) D pop H pop L A mov E sub A L mov H A mov D sbb A H mov hpush jmp end-code Code negate ( n1 -- n2 ) H pop H dcx >not jmp end-code \\ : - ( n1 n2 -- n3 ) negate + ; \ dnegate d+ 10Mar86 18Nov87 Code dnegate ( d1 -- -d1 ) H pop Label >dnegate D pop A sub E sub A E mov 0 A mvi D sbb A D mov 0 A mvi L sbb A L mov 0 A mvi H sbb A H mov dpush jmp end-code Code d+ ( d1 d2 -- d3) 6 H lxi SP dad M E mov C M mov H inx M D mov B M mov B pop H pop D dad xchg H pop L A mov C adc A L mov H A mov B adc A H mov B pop dpush jmp end-code \ 1+ 2+ 3+ 4+ 6+ 1- 2- 4- 27Apr86Code 1+ ( n1 -- n2 ) H pop H inx hpush jmp end-code Code 2+ ( n1 -- n2 ) H pop H inx H inx hpush jmp end-code Code 3+ ( n1 -- n2 ) H pop H inx H inx H inx hpush jmp end-code Code 4+ ( n1 -- n2 ) H pop 4 D lxi D dad hpush jmp end-code | Code 6+ ( n1 -- n2 ) H pop 6 D lxi D dad hpush jmp end-code Code 1- ( n1 -- n2 ) H pop H dcx hpush jmp end-code Code 2- ( n1 -- n2 ) H pop H dcx H dcx hpush jmp end-code Code 4- ( n1 -- n2 ) H pop -4 D lxi D dad hpush jmp end-code \ number Constants 07Oct87-1 Constant true 0 Constant false 0 ( -- 0 ) Constant 0 1 ( -- 1 ) Constant 1 2 ( -- 2 ) Constant 2 3 ( -- 3 ) Constant 3 4 ( -- 4 ) Constant 4 -1 ( -- -1 ) Constant -1 Code on ( addr -- ) H pop $FF A mvi Label set A M mov H inx A M mov Next Code off ( addr -- ) H pop A xra set jmp end-code \ : on ( addr -- ) true swap ! ; \ : off ( addr -- ) false swap ! ; \ words for number literals 16May86 Code lit ( -- 16b ) IP ldax A L mov IP inx IP ldax A H mov IP inx hpush jmp end-code Code clit ( -- 8b ) IP ldax A L mov 0 H mvi IP inx hpush jmp end-code : Literal ( 16b -- ) dup $FF00 and IF compile lit , exit THEN compile clit c, ; immediate restrict \ comparision words 18Nov87Label (u< ( HL,DE -> HL u< DE c,z ) H A mov D cmp rnz L A mov E cmp ret Label (< ( HL,DE -> HL < DE c,z ) H A mov D xra (u< jp D A mov H cmp ret Label yes true H lxi hpush jmp Code u< ( u1 u2 -- flag ) D pop H pop Label uless (u< call yes jc Label no false H lxi hpush jmp Code < ( n1 n2 -- flag ) D pop H pop Label less (< call yes jc no jmp end-code Code u> ( u1 u2 -- flag ) H pop D pop uless jmp end-code Code > ( n1 n2 -- flag ) H pop D pop less jmp end-code \ comparision words 18Nov87Code 0< ( n1 n2 -- flag ) H pop Label negative H dad yes jc no jmp end-code Code 0> ( n -- flag ) H pop H A mov A ora no jm L ora yes jnz no jmp end-code Code 0= ( n -- flag ) H pop Label zero= H A mov L ora yes jz no jmp end-code Code 0<> ( n -- flag ) H pop H A mov L ora yes jnz no jmp end-code Code = ( n1 n2 -- flag ) H pop D pop L A mov E cmp no jnz H A mov D cmp no jnz yes jmp end-code \\ comparision words high level 18Nov87: 0< ( n1 -- flag ) 8000 and 0<> ; : > ( n1 n2 -- flag ) swap < ; : 0> ( n -- flag ) negate 0< ; : 0<> ( n -- flag ) 0= not ; : u> ( u1 u2 -- flag ) swap u< ; : = ( n1 n2 -- flag ) - 0= ; : uwithin ( u1 [low up[ -- flag ) over - -rot - u> ; | : minimax ( n1 n2 flag -- n3 ) rdrop IF swap THEN drop ; : min ( n1 n2 -- n3 ) 2dup > minimax ; : max ( n1 n2 -- n3 ) 2dup < minimax ; : umax ( u1 u2 -- u3 ) 2dup u< minimax ; : umin ( u1 u2 -- u3 ) 2dup u> minimax ; : extend ( n -- d ) dup 0< ; : dabs ( d -- ud ) extend IF dnegate THEN ; : abs ( n -- u) extend IF negate THEN ; \ uwthin double number comparison words 18Nov87 Code uwithin ( u1 [low up[ -- flag ) H pop D pop xthl (u< call cs ?[ H pop no jmp ]? D pop (u< call yes jc no jmp end-code Code d0= ( d -- flag ) H pop H A mov L ora H pop no jnz zero= jmp end-code : d= ( d1 d2 -- flag ) rot = -rot = and ; : d< ( d1 d2 -- flag ) rot 2dup = IF 2drop u< exit THEN > nip nip ; \\ : d0= ( d -- flag ) or 0= ; \ minimum maximum 18Nov87 Code umax ( u1 u2 -- u3 ) H pop D pop (u< call Label minimax cs ?[ xchg ]? hpush jmp end-code Code umin ( u1 u2 -- u3 ) H pop D pop (u< call cmc minimax jmp end-code Code max ( n1 n2 -- n3 ) H pop D pop (< call minimax jmp end-code Code min ( n1 n2 -- n3 ) H pop D pop (< call cmc minimax jmp end-code \ sign extension absolute values 18Nov87 Code extend ( n -- d ) H pop H push negative jmp end-code Code abs ( a -- u ) H pop H A mov A ora hpush jp H dcx >not jmp end-code Code dabs ( d -- ud ) H pop H A mov A ora hpush jp >dnegate jmp end-code \ branch ?branch 20Nov87 Code branch ( -- ) Label >branch IP H mvx M E mov H inx M D mov H dcx D dad H IP mvx Next end-code Code ?branch ( fl -- ) H pop H A mov L ora >branch jz IP inx IP inx Next end-code \\ : branch r> dup @ + >r ; \ loop primitives 11Jun86 20Nov87 Code bounds ( start count -- limit start ) H pop D pop D dad H push D push Next end-code Code endloop RP lhld 6 D lxi D dad RP shld next end-code restrict \\ dodo puts "index | limit | adr.of.DO" on return-stack : bounds ( start count -- limit start ) over + swap ; | : dodo rdrop r> 2+ dup >r rot >r swap >r >r ; : (do ( limit start -- ) over - dodo ; restrict : (?do ( limit start -- ) over - ?dup IF dodo THEN r> dup @ + >r drop ; restrict \ loop primitives 20Nov87 Code (do ( limit start -- ) H pop D pop Label >do L A mov E sub A L mov H A mov D sbb A H mov H push IP inx IP inx RP lhld H dcx IP M mov H dcx IP' M mov H dcx D M mov H dcx E M mov D pop H dcx D M mov H dcx E M mov RP shld Next end-code restrict Code (?do ( limit start -- ) H pop D pop H A mov D cmp >do jnz L A mov E cmp >do jnz >branch jmp end-code restrict \ (loop (+loop 14May86 20Nov87 Code (loop RP lhld M inr 0= ?[ H inx M inr >next jz ]? Label doloop RP lhld 4 D lxi D dad M IP' mov H inx M IP mov Next end-code restrict Code (+loop RP lhld D pop M A mov E add A M mov H inx M A mov D adc A M mov rar D xra doloop jp Next end-code restrict \ loop indices 06May86 20Nov87 Code I ( -- n ) RP lhld Label >I M E mov H inx M D mov D push H inx M E mov H inx M D mov H pop D dad hpush jmp end-code Code J ( -- n ) RP lhld 6 D lxi D dad >I jmp end-code \ interpretive conditionals UH 25Jan88 | Create: remove>> r> rp! ; | : >>r ( addr len -- addr ) r> over rp@ under swap - dup rp! swap >r remove>> >r swap >r dup >r swap cmove r> ; | Variable saved-dp 0 saved-dp ! | Variable level 0 level ! | : +level ( -- ) level @ IF 1 level +! exit THEN state @ ?exit 1 level ! here saved-dp ! ] ; | : -level ( -- ) state @ 0= Abort" unstructured" level @ 0=exit -1 level +! level @ ?exit compile unnest [compile] [ saved-dp @ here over dp ! over - >>r >r ; \ resolve loops and branches UH 25Jan88 : >mark ( -- addr ) here 0 , ; : +>mark ( acf -- addr ) +level , >mark ; : >resolve ( addr -- ) here over - swap ! -level ; : mark 1 ; immediate : THEN abs 1 ?pairs >resolve ; immediate : ELSE 1 ?pairs ['] branch +>mark swap >resolve -1 ; immediate : BEGIN mark -2 2swap ; immediate | : (reptil resolve REPEAT ; : REPEAT 2 ?pairs compile branch (reptil ; immediate : UNTIL 2 ?pairs compile ?branch (reptil ; immediate \ Loops UH 25Jan88 : DO ['] (do +>mark 3 ; immediate : ?DO ['] (?do +>mark 3 ; immediate : LOOP 3 ?pairs compile (loop compile endloop >resolve ; immediate : +LOOP 3 ?pairs compile (+loop compile endloop >resolve ; immediate Code LEAVE RP lhld 4 D lxi D dad M E mov H inx M D mov H inx RP shld xchg H dcx M D mov H dcx M E mov D dad H IP mvx Next end-code restrict \\ Returnstack: calladr | index limit | adr of DO : LEAVE endloop r> 2- dup @ + >r ; restrict \ um* 16May86Label (um* 0 H lxi ( 0=Teil-Produkt ) 4 C mvi ( Schleifen-Zaehler ) [[ H dad ( Schiebe HL 24 bits nach links ) ral cs ?[ D dad 0 aci ]? H dad ral cs ?[ D dad 0 aci ]? C dcr 0= ?] ret Code um* ( u1 u2 -- ud ) D pop H pop B push H B mov L A mov (um* call H push A H mov B A mov H B mov (um* call D pop D C mov B dad 0 aci L D mov H L mov A H mov B pop dpush jmp end-code \ m* * 2* 2/ 16May86 : m* ( n1 n2 -- d ) dup 0< dup >r IF negate THEN swap dup 0< IF negate r> not >r THEN um* r> IF dnegate THEN ; : * ( n1 n2 - prod ) um* drop ; Code 2* ( n -- 2*n ) H pop H dad hpush jmp end-code Code 2/ ( n -- n/2 ) H pop H A mov rlc rrc rar A H mov L A mov rar A L mov hpush jmp end-code \\ : 2* ( n -- 2*n ) 2 * ; : 2/ ( n -- n/2 ) 2 / ; \ um/mod 14May86Label usl0 A E mov H A mov C sub A H mov E A mov B sbb cs ?[ H A mov C add A H mov E A mov D dcr rz Label usla H dad ral usl0 jnc A E mov H A mov C sub A H mov E A mov B sbb ]? L inr D dcr usla jnz ret Label usbad -1 H lxi B pop H push hpush jmp Code um/mod ( d1 n1 -- rem quot ) IP H mvx B pop D pop xthl xchg L A mov C sub H A mov B sbb usbad jnc H A mov L H mov D L mov 8 D mvi D push usla call D pop H push E L mov usla call A D mov H E mov B pop C H mov B pop D push hpush jmp end-code \ m/mod 16May86 : m/mod ( d n -- mod quot) dup >r abs over 0< IF under + swap THEN um/mod r@ 0< IF negate over IF swap r@ + swap 1- THEN THEN rdrop ; \ /mod / mod */mod */ u/mod ud/mod 16May86 : /mod ( n1 n2 -- rem quot ) >r extend r> m/mod ; : / ( n1 n2 -- quot ) /mod nip ; : mod ( n1 n2 -- rem ) /mod drop ; : */mod ( n1 n2 n3 -- rem quot ) >r m* r> m/mod ; : */ ( n1 n2 n3 -- quot ) */mod nip ; : u/mod ( u1 u2 -- urem uquot ) 0 swap um/mod ; : ud/mod ( ud1 u2 -- urem udquot ) >r 0 r@ um/mod r> swap >r um/mod r> ; \ cmove cmove> 16May86 18Nov87 Code cmove ( from to count -- ) IP H mvx IPsave shld B pop D pop H pop Label (cmove [[ B A mov C ora 0= not ?[[ M A mov H INX D stax D inx B dcx ]]? IPsave lhld H IP mvx Next end-code Code cmove> ( from to count -- ) IP H mvx IPsave shld B pop D pop H pop Label (cmove> B dad H dcx xchg B dad H dcx xchg [[ B A mov C ora 0= not ?[[ M A mov H dcx D stax D dcx B dcx ]]? IPsave lhld H IP mvx Next end-code \ move place count 17Oct86 18Nov87 Code move ( from to quan -- ) IP H mvx Ipsave shld B pop D pop H pop Label domove (u< call (cmove jnc (cmove> jmp end-code | Code (place ( addr len to -- len to ) IP H mvx Ipsave shld D pop B pop H pop B push D push D inx domove jmp end-code : place ( addr len to -- ) (place c! ; Code count ( adr -- adr+1 len ) H pop M E mov 0 D mvi H inx H push D push Next end-code \ fill erase 18Nov87 Code fill ( addr quan 8b -- ) IP H mvx IPsave shld D pop B pop H pop [[ B A mov C ora 0<> ?[[ E M mov H inx B dcx ]]? IPsave lhld H IP mvx Next end-code : erase ( addr quan --) 0 fill ; \\ : fill ( addr quan 8b -- ) swap ?dup IF >r over c! dup 1+ r> 1- cmove exit THEN 2drop ; : count ( adr -- adr+1 len ) dup 1+ swap c@ ; : move ( from to quan -- ) >r 2dup u< IF r> cmove> exit THEN r> cmove ; : place ( addr len to --) over >r rot over 1+ r> move c! ; \ here allot , c, pad compile 11Jun86 18Nov87 Code here ( -- addr ) user' dp D lxi UP lhld D dad fetch jmp end-code Code allot ( n -- ) user' dp D lxi UP lhld D dad +store jmp end-code : , ( 16b -- ) here ! 2 allot ; : c, ( 8b -- ) here c! 1 allot ; : pad ( -- addr ) here $42 + ; : compile r> dup 2+ >r @ , ; restrict \ : here ( -- addr ) dp @ ; \ : allot ( n -- ) dp +! ; \ input strings 11Jun86 Variable #tib 0 #tib ! Variable >tib here >tib ! $50 allot Variable >in 0 >in ! Variable blk 0 blk ! Variable span 0 span ! : tib ( -- addr ) >tib @ ; : query ( -- ) tib $50 expect span @ #tib ! >in off blk off ; \\ scan skip /string 16May86 18Nov87 : scan ( addr0 len0 char -- addr1 len1 ) >r BEGIN dup WHILE over c@ r@ - WHILE 1- swap 1+ swap REPEAT rdrop ; : skip ( addr len del -- addr1 len1 ) >r BEGIN dup WHILE over c@ r@ = WHILE 1- swap 1+ swap REPEAT rdrop ; : /string ( addr0 len0 +n - addr1 len1 ) over umin rot over + -rot - ; \ skip scan 18Nov87Label done H push B push IPsave lhld H IP mvx Next Code skip ( addr len del -- addr1 len1 ) IP H mvx IPsave shld D pop B pop H pop [[ B A mov C ora done jz M A mov E cmp done jnz H inx B dcx ]] end-code Code scan ( addr len chr -- addr1 len1 ) IP H mvx IPsave shld D pop B pop H pop [[ B A mov C ora done jz M A mov E cmp done jz H inx B dcx ]] end-code Code /string ( addr0 len0 +n - addr1 len1 ) H pop D pop D push (u< call cs ?[ xchg ]? H pop xthl D dad xthl L A mov E sub A L mov H A mov D sbb A H mov Hpush jmp end-code \ capitalize ohne Umlaute !! 16May86UH 25Jan88Variable caps 0 caps ! Label ?capital caps lda A ana rz Label (capital ( e --> A,E ) E A mov Ascii a cpi rc Ascii z 1+ cpi rnc Ascii a Ascii A - sui A E mov ret Code capital ( char -- char') D pop (capital call D push Next end-code Code upper ( addr len -- ) D pop E D mov H pop D inr [[ D dcr >next jz M E mov (capital call E M mov H inx ]] end-code \\ : capital ( char -- char') dup Ascii a [ Ascii z 1+ ] Literal uwithin not ?exit [ Ascii a Ascii A - ] Literal - ; : upper ( addr len -- ) bounds ?DO I c@ capital I c! LOOP ; \ (word 16May86 Code (word ( char adr0 len0 -- addr ) IP H mvx IPsave shld B pop B dcx D pop >in lhld D dad xchg xthl xchg H push >in lhld C A mov L sub A L mov B A mov H sbb A H mov cs ?[ B inx C A mov >in sta B A mov >in 1+ sta D pop H pop D push ][ H inx H B mvx H pop [[ B A mov C ora 0<> ?[[ M A mov E cmp 0= ?[[ H inx B dcx ]]? ]? H push [[ B A mov C ora 0<> ?[[ M A mov E cmp 0<> ?[[ H inx B dcx ]]? ]? xchg H pop xthl E A mov L sub A L mov D A mov H sbb A H mov \ (word Part2 16May86 B A mov C ora 0<> ?[ H inx ]? >in shld ]? H pop E A mov L sub A C mov D A mov H sbb A B mov H push user' dp D lxi UP lhld D dad M A mov H inx M H mov A L mov D pop H push C M mov H inx [[ B A mov C ora 0<> ?[[ D ldax A M mov H inx D inx B dcx ]]? bl M mvi IPsave lhld H IP mvx Next end-code \\ : (word ( char adr0 len0 -- addr ) rot >r over swap >in @ /string r@ skip over swap r> scan >r rot over swap - r> 0<> - >in ! over - here dup >r place bl r@ count + c! r> ; \ source word parse name 20Oct86UH 25Jan88 Variable loadfile : source ( -- addr len ) blk @ ?dup IF loadfile @ (block b/blk exit THEN tib #tib @ ; : word ( char -- addr ) source (word ; : parse ( char -- addr len ) >r source >in @ /string over swap r> scan >r over - dup r> 0<> - >in +! ; : name ( -- addr ) bl word dup count upper exit ; \ state Ascii ," "lit (" " 18Nov87 Variable state 0 state ! : Ascii ( char -- n ) bl word 1+ c@ state @ IF [compile] Literal THEN ; immediate Code "lit RP lhld M E mov H inx M D mov H dcx D push D ldax D inx E add A M mov H inx D A mov 0 aci A M mov Next end-code : ," Ascii " parse here over 1+ allot place ; : (" "lit ; restrict : " compile (" ," align ; immediate restrict \ : "lit r> r> under count + even >r >r ; restrict \ ." ( .( \ \\ hex decimal 07Oct87 : (." "lit count type ; restrict : ." compile (." ," align ; immediate restrict : ( ascii ) parse 2drop ; immediate : .( ascii ) parse type ; immediate : \ >in @ negate c/l mod >in +! ; immediate : \\ b/blk >in ! ; immediate : \needs name find nip 0=exit [compile] \ ; : hex $10 base ! ; : decimal $0A base ! ; \ number conversion: digit? 16May86 18Nov87 Code digit? ( char -- n true : false ) user' base D lxi UP lhld D dad D pop E A mov Ascii 0 sui no jc $0A cpi cs not ?[ Ascii A Ascii 0 - cpi no jc Ascii A Ascii 9 - 1- sui ]? M cmp no jnc 0 H mvi A L mov H push yes jmp end-code \\ : digit? ( char -- digit true/ false ) dup Ascii 9 > IF [ Ascii A Ascii 9 - 1- ] Literal - dup Ascii 9 > and THEN Ascii 0 - dup base @ u< dup ?exit nip ; \ number conversion: accumulate convert 11Jun86 | : end? ( -- flag ) >in @ 0= ; | : char ( addr0 -- addr1 char ) count -1 >in +! ; | : previous ( addr0 -- addr0 char ) 1- count ; : accumulate ( +d0 adr digit - +d1 adr ) swap >r swap base @ um* drop rot base @ um* d+ r> ; : convert ( +d1 addr0 -- +d2 addr2 ) 1+ BEGIN count digit? WHILE accumulate REPEAT 1- ; \ number conversion: ?nonum punctuation? 07Oct87 | : ?nonum ( flag -- exit if true ) 0=exit rdrop 2drop drop rdrop false ; | : punctuation? ( char -- flag ) Ascii , over = swap Ascii . = or ; \ number conversion: fixbase? 07Oct87 | : fixbase? ( char - char false / newbase true ) capital Ascii & case? IF $0A true exit THEN Ascii $ case? IF $10 true exit THEN Ascii H case? IF $10 true exit THEN Ascii % case? IF 2 true exit THEN false ; \ number conversion: ?num ?dpl 07Oct87 Variable dpl -1 dpl ! | : ?num ( flag -- exit if true ) 0=exit rdrop drop r> IF dnegate THEN rot drop dpl @ 1+ ?dup ?exit drop true ; | : ?dpl dpl @ -1 = ?exit 1 dpl +! ; \ number conversion: number? number 11Jun86 : number? ( string - string false / n 0< / d 0> ) base push >in push dup count >in ! dpl on 0 >r ( +sign) 0.0 rot end? ?nonum char Ascii - case? IF rdrop true >r end? ?nonum char THEN fixbase? IF base ! end? ?nonum char THEN BEGIN digit? 0= ?nonum BEGIN accumulate ?dpl end? ?num char digit? 0= UNTIL previous punctuation? 0= ?nonum dpl off end? ?num char REPEAT ; : number ( string -- d ) number? ?dup 0= Abort" ?" 0< IF extend THEN ; \ hide reveal immediate restrict 11Jun86 Variable last 0 last ! | : last? ( -- false / acf true) last @ ?dup ; : hide last? IF 2- @ current @ ! THEN ; : reveal last? IF 2- current @ ! THEN ; : Recursive reveal ; immediate restrict | : flag! ( 8b --) last? IF under c@ or over c! THEN drop ; : immediate $40 flag! ; : restrict $80 flag! ; \ clearstack hallot heap heap? 04Sep86 Code clearstack user' s0 D lxi UP lhld D dad M E mov H inx M D mov xchg sphl Next end-code : hallot ( quan -- ) s0 @ over - swap sp@ 2+ dup rot - dup s0 ! 2 pick over - di move clearstack ei s0 ! ; : heap ( -- addr ) s0 @ 6 + ; : heap? ( addr -- flag ) heap up@ uwithin ; | : heapmove ( from -- from ) dup here over - dup hallot heap swap cmove heap over - last +! reveal ; \ Does> ; 11Jun86 20Nov87 Label (dodoes> IP rpush IP pop W inx W push Next end-code : (;code r> last @ name> ! ; : Does> compile (;code $CD ( 8080-Call ) c, compile (dodoes> ; immediate restrict \ ?head | alignments 20Oct86 18Nov87 Variable ?head 0 ?head ! : | ?head @ ?exit -1 ?head ! ; \ machen nichts beim 8080: : even ( addr -- addr1 ) ; immediate : align ( -- ) ; immediate : halign ( -- ) ; immediate Variable warning 0 warning ! | : exists? warning @ ?exit last @ current @ (find nip 0=exit space last @ .name ." exists " ?cr ; \ warning Create 20Oct86 18Nov87 Defer makeview ' 0 Is makeview : (create ( string -- ) align here swap count $1F and here 4+ place makeview , current @ @ , here last ! here c@ 1+ allot align exists? ?head @ IF 1 ?head +! dup , \ Pointer to Code halign heapmove $20 flag! dup dp ! THEN drop reveal 0 , ;Code W inx W push Next end-code : Create name count 1 $20 uwithin not Abort" invalid name" 1- (create ; \ nfa? 30Jun86 Code nfa? ( thread cfa -- nfa / false ) D pop H pop [[ M A mov H inx M H mov A L mov H ora Hpush jz H push H inx H inx H push D push M A mov H inx $1F ani A E mov 0 D mvi D dad D pop xthl M A mov H pop $20 ani 0<> ?[ M A mov H inx M H mov A L mov ]? H A mov D cmp 0= ?[ L A mov E cmp ]? H pop 0= ?] H inx H inx Hpush jmp end-code \\ : nfa? ( thread cfa -- nfa / false) >r BEGIN @ dup 0= IF rdrop exit THEN dup 2+ name> r@ = UNTIL 2+ rdrop ; \ >name name> >body .name 30Jun86 07Oct87 : >name ( cfa -- nfa / false ) voc-link BEGIN @ dup WHILE 2dup 4 - swap nfa? ?dup IF -rot 2drop exit THEN REPEAT nip ; Code (name> ( nfa -- cfa ) H pop M A mov H inx $1F ani A E mov 0 D mvi D dad hpush jmp end-code \ : (name> ( nfa -- cfa ) count $1F and + ; : name> ( nfa -- cfa ) dup (name> swap c@ $20 and IF @ THEN ; : >body ( cfa -- pfa ) 2+ ; : body> ( pfa -- cfa ) 2- ; : .name ( nfa -- ) ?dup IF dup heap? IF ." |" THEN count $1F and type ELSE ." ???" THEN space ; \ : ; Constant Variable 07Nov87 : Create: Create hide current @ context ! 0 ] ; : : Create: ;Code IP rpush W inx W IP mvx Next end-code : ; 0 ?pairs compile unnest [compile] [ reveal ; immediate restrict : Constant ( n -- ) Create , ;Code W inx xchg M E mov H inx M D mov D push Next end-code : Variable Create 0 , ; \ uallot User Alias Defer 11Jun86 18Nov87: uallot ( quan -- offset ) even dup udp @ + $FF u> Abort" Userarea full" udp @ swap udp +! ; : User Create 2 uallot c, ;Code W inx W ldax A E mov 0 D mvi UP lhld D dad hpush jmp end-code : Alias ( cfa -- ) Create last @ dup c@ $20 and IF -2 allot ELSE $20 flag! THEN (name> ! ; | : crash true Abort" crash" ; : Defer Create ['] crash , ;Code W inx xchg M E mov H inx M D mov xchg >next1 jmp end-code \ vp current context also toss 11Jun86 Create vp $10 allot Variable current : context ( -- adr ) vp dup @ + 2+ ; | : thru.vocstack ( -- from to ) vp 2+ context ; \ "Only Forth also Assembler" gives \ vp: countword = 6 | Only | Forth | Assembler | : also vp @ $0A > Error" Vocabulary stack full" context @ 2 vp +! context ! ; : toss vp @ IF -2 vp +! THEN ; \ Vocabulary Forth Only Onlyforth 24Nov85 18Nov87 : Vocabulary Create 0 , 0 , here voc-link @ , voc-link ! Does> context ! ; \ | Name | Code | Thread | Coldthread | Voc-link | Vocabulary Forth Vocabulary Root : Only vp off Root also ; : Onlyforth Only Forth also definitions ; \ definitions order words 10Oct87 20Nov87 | : init-vocabularys voc-link @ BEGIN dup 2- @ over 4- ! @ ?dup 0= UNTIL ; : definitions context @ current ! ; | : .voc ( adr -- ) @ 2- >name .name ; : order vp 4+ context DO I .voc -2 +LOOP 2 spaces current .voc ; : words context @ BEGIN @ dup stop? 0= and WHILE ?cr dup 2+ .name space REPEAT drop ; \ found -text 11Jun86| : found ( nfa -- cfa n ) dup c@ >r (name> r@ $20 and IF @ THEN -1 r@ $80 and IF 1- THEN r> $40 and IF negate THEN ; \\ : -text ( adr1 u adr2 -- false:gleich/+1:str1>str2/-1:str1r count $1F and strlen ! string ! BEGIN r> ?dup WHILE dup @ >r 2+ dup c@ $1F and strlen @ = IF dup 1+ strlen @ string @ -text 0= ?dup IF rdrop exit THEN THEN drop REPEAT string @ 1- false ; \ (find 11Jun86 Code (find ( str thr - str false/ NFA true ) H pop D pop IP push D ldax $1F ani A C mov D inx Label findloop M A mov H inx M H mov A L mov H A mov L ora 0= ?[ IP pop D dcx D push no jmp ]? H push H inx H inx M A mov $1F ani C cmp 0<> ?[ H pop findloop jmp ]? D push H inx C B mov B inr [[ B dcr 0<> ?[[ D ldax M cmp 0<> ?[ D pop H pop findloop jmp ]? H inx D inx ]]? D pop H pop H inx H inx IP pop H push yes jmp end-code \\ HL: thread, nfa DE: string C: strlen B: counter \ find ' [compile] ['] nullstring? 18Nov87 : find ( string -- cfa n / string false ) context dup @ over 2- @ = IF 2- THEN BEGIN under @ (find IF nip found exit THEN over vp 2+ u> WHILE swap 2- REPEAT nip false ; : ' ( -- cfa ) name find ?exit Error" ?" ; : [compile] ' , ; immediate restrict : ['] ' [compile] Literal ; immediate restrict : nullstring? ( string -- string false / true ) dup c@ 0= dup 0=exit nip ; \ notfound 17Oct86UH 25Jan88 : no.extensions ( string -- ) state @ IF Abort" ?" THEN Error" ?" ; Defer notfound ' no.extensions Is notfound \ interpret interpreter compiler parser UH 25Jan88Defer parser : interpret ( -- ) BEGIN ?stack name nullstring? ?exit parser REPEAT ; | : interpreter ( str -- ) find ?dup IF 1 and IF execute exit THEN Error" compile only" THEN number? ?exit notfound ; ' interpreter Is parser | : compiler ( str -- ) find ?dup IF 0> IF execute exit THEN , exit THEN number? ?dup IF 0> IF swap [compile] Literal THEN [compile] Literal exit THEN notfound ; \ [ ] UH 25Jan88 : [ ['] interpreter Is Parser state off ; immediate : ] ['] compiler Is Parser state on ; \ Is 09May86UH 25Jan88 : (is r> dup 2+ >r @ ! ; | : def? ( cfa -- ) @ [ ' notfound @ ] Literal - Abort" not deferred" ; : Is ( adr -- ) ' dup def? >body state @ IF compile (is , exit THEN ! ; immediate \ ?stack 30Jun86| : stackfull ( -- ) depth $20 > Abort" tight stack" reveal last? IF dup heap? IF name> ELSE 4- THEN (forget THEN true Abort" Dictionary full" ; Code ?stack UP lhld user' dp D lxi D dad M E mov H inx M D mov 0 H lxi SP dad L A mov E sub H A mov D sbb 0= ?[ ;c: stackfull ; Assembler ]? H push UP lhld user' s0 D lxi D dad M E mov H inx M D mov H pop D A mov H cmp c0= ?[ 0= ?[ E A mov L cmp ]? ]? >next jnc ;c: true abort" Stack empty" ; \\ : ?stack sp@ here - 100 u< IF stackfull THEN sp@ s0 @ u> Abort" Stack empty" ; \ .status push load 20Oct86 Defer .status ' noop Is .status | Create: pull r> r> ! ; : push ( addr -- ) r> swap dup >r @ >r pull >r >r ; restrict : (load ( blk offset -- ) isfile push loadfile push fromfile push blk push >in push >in ! blk ! isfile@ loadfile ! .status interpret ; : load ( blk --) ?dup 0=exit 0 (load ; \ +load thru +thru --> rdepth depth 20Oct86 : +load ( offset --) blk @ + load ; : thru ( from to --) 1+ swap DO I load LOOP ; : +thru ( off0 off1 --) 1+ swap DO I +load LOOP ; : --> 1 blk +! >in off .status ; immediate : rdepth ( -- +n) r0 @ rp@ 2+ - 2/ ; : depth ( -- +n) sp@ s0 @ swap - 2/ ; \ quit (quit abort UH 25Jan88 : (prompt ( -- ) state @ IF cr ." ] " ELSE ." ok" cr THEN .status ; Defer prompt ' (prompt Is prompt : (quit BEGIN prompt query interpret REPEAT ; Defer 'quit ' (quit Is 'quit : quit r0 @ rp! level off [compile] [ 'quit ; : standardi/o [ output ] Literal output 4 cmove ; Defer 'abort ' noop Is 'abort : abort end-trace clearstack 'abort standardi/o quit ; \ (error Abort" Error" 20Oct86 18Nov87 Variable scr 1 scr ! Variable r# 0 r# ! : (error ( string -- ) standardi/o space here .name count type space ?cr blk @ ?dup IF scr ! >in @ r# ! THEN quit ; ' (error errorhandler ! : (abort" "lit swap IF >r clearstack r> errorhandler perform exit THEN drop ; restrict | : (err" "lit swap IF errorhandler perform exit THEN drop ; restrict : Abort" compile (abort" ," align ; immediate restrict : Error" compile (err" ," align ; immediate restrict \ -trailing 30Jun86 18Nov87 Code -trailing ( addr n1 -- addr n2 ) D pop H pop H push D dad xchg D dcx Label -trail H A mov L ora hpush jz D ldax BL cpi hpush jnz H dcx D dcx -trail jmp end-code \\ : -trailing ( addr n1 -- addr n2) 2dup bounds ?DO 2dup + 1- c@ bl - IF LEAVE THEN 1- LOOP ; \ space spaces 30Jun86 $20 Constant bl : space bl emit ; : spaces ( u --) 0 ?DO space LOOP ; \ hold <# #> sign # #s 17Oct86 | : hld ( -- addr) pad 2- ; : hold ( char -- ) -1 hld +! hld @ c! ; : <# hld hld ! ; : #> ( 32b -- addr +n ) 2drop hld @ hld over - ; : sign ( n -- ) 0< IF Ascii - hold THEN ; : # ( +d1 -- +d2) base @ ud/mod rot 9 over < IF [ Ascii A Ascii 9 - 1- ] Literal + THEN Ascii 0 + hold ; : #s ( +d -- 0 0 ) BEGIN # 2dup d0= UNTIL ; \ print numbers 24Dec83 : d.r -rot under dabs <# #s rot sign #> rot over max over - spaces type ; : .r swap extend rot d.r ; : u.r 0 swap d.r ; : d. 0 d.r space ; : . extend d. ; : u. 0 d. ; \ .s list c/l l/s 05Oct87 : .s sp@ s0 @ over - $20 umin bounds ?DO I @ u. 2 +LOOP ; $40 Constant c/l \ Screen line length $10 Constant l/s \ lines per screen : list ( blk -- ) scr ! ." Scr " scr @ u. l/s 0 DO cr I 2 .r space scr @ block I c/l * + c/l -trailing type LOOP cr ; \ multitasker primitives 20Nov87 Code end-trace \ patch Next to its original state $0A A mvi ( IP ldax ) >next sta $6F03 H lxi ( IP inx A L mov ) >next 1+ shld Next end-code Code pause >next here 2- ! end-code : lock ( addr -- ) dup @ up@ = IF drop exit THEN BEGIN dup @ WHILE pause REPEAT up@ swap ! ; : unlock ( addr -- ) dup lock off ; Label wake H pop H dcx UP shld 6 D lxi D dad M A mov H inx M H mov A L mov sphl H pop RP shld IP pop Next end-code \ buffer mechanism 20Oct86 07Oct87 User isfile 0 isfile ! \ addr of file control block Variable fromfile 0 fromfile ! Variable prev 0 prev ! \ Listhead | Variable buffers 0 buffers ! \ Semaphor $408 Constant b/buf \ physikalische Groesse $400 Constant b/blk \\ Struktur eines Buffers: 0 : link 2 : file 4 : blocknummer 6 : statusflags 8 : Data ... 1 Kb ... Statusflag bits : 15 1 -> updated file : -1 -> empty buffer, 0 -> no fcb, direct access else addr of fcb ( system dependent ) \ search for blocks in memory 30Jun86| Variable pred \ DE:blk BC:file HL:bufadr Label thisbuffer? ( Zero = this buffer ) H push H inx H inx M A mov C cmp 0= ?[ H inx M A mov B cmp 0= ?[ H inx M A mov E cmp 0= ?[ H inx M A mov D cmp ]? ]? ]? H pop ret Code (core? ( blk file -- adr\blk file ) IP H mvx Ipsave shld user' offset D lxi UP lhld D dad M E mov H inx M D mov B pop H pop H push B push D dad xchg prev lhld thisbuffer? call 0= ?[ \ search for blocks in memory 30Jun86 Label blockfound D pop D pop 8 D lxi D dad H push ' exit @ jmp ]? [[ pred shld M A mov H inx M H mov A L mov H ora 0= ?[ IPsave lhld H IP mvx Next ]? thisbuffer? call 0= ?] xchg pred lhld D ldax A M mov H inx D inx D ldax A M mov D dcx prev lhld xchg E M mov H inx D M mov H dcx prev shld blockfound jmp end-code \ (core? 29Jun86\\ | : this? ( blk file bufadr -- flag ) dup 4+ @ swap 2+ @ d= ; | : (core? ( blk file -- dataaddr / blk file ) BEGIN over offset @ + over prev @ this? IF rdrop 2drop prev @ 8 + exit THEN 2dup >r offset @ + >r prev @ BEGIN dup @ ?dup 0= IF rdrop rdrop drop exit THEN dup r> r> 2dup >r >r rot this? 0= WHILE nip REPEAT dup @ rot ! prev @ over ! prev ! rdrop rdrop REPEAT ; \ (diskerr 29Jul86 07Oct87 : (diskerr ." error! r to retry " key $FF and capital Ascii R = not Abort" aborted" ; Defer diskerr ' (diskerr Is diskerr Defer r/w \ backup emptybuf readblk 20Oct86 | : backup ( bufaddr -- ) dup 6+ @ 0< IF 2+ dup @ 1+ \ buffer empty if file = -1 IF input push output push standardi/o BEGIN dup 6+ over 2+ @ 2 pick @ 0 r/w WHILE ." write " diskerr REPEAT THEN 4+ dup @ $7FFF and over ! THEN drop ; : emptybuf ( bufaddr -- ) 2+ dup on 4+ off ; | : readblk ( blk file addr -- blk file addr ) dup emptybuf input push output push standardi/o >r BEGIN over offset @ + over r@ 8 + -rot 1 r/w WHILE ." read " diskerr REPEAT r> ; \ take mark updates? core? 10Mar86 19Nov87 | : take ( -- bufaddr) prev BEGIN dup @ WHILE @ dup 2+ @ -1 = UNTIL buffers lock dup backup ; | : mark ( blk file bufaddr -- blk file ) 2+ >r 2dup r@ ! offset @ + r@ 2+ ! r> 4+ off buffers unlock ; | : updates? ( -- bufaddr / flag) prev BEGIN @ dup WHILE dup 6+ @ 0< UNTIL ; : core? ( blk file -- addr /false ) (core? 2drop false ; \ block & buffer manipulation 20Oct86 18Nov87 : (buffer ( blk file -- addr ) BEGIN (core? take mark REPEAT ; : (block ( blk file -- addr ) BEGIN (core? take readblk mark REPEAT ; Code isfile@ ( -- addr ) user' isfile D lxi UP lhld D dad fetch jmp end-code : buffer ( blk -- addr ) isfile@ (buffer ; : block ( blk -- addr ) isfile@ (block ; \ : isfile@ ( -- addr ) isfile @ ; \ block & buffer manipulation 05Oct87 : update $80 prev @ 6+ 1+ ( Byte-Order! ) c! ; Defer save-dos-buffers : save-buffers ( -- ) buffers lock BEGIN updates? ?dup WHILE backup REPEAT save-dos-buffers buffers unlock ; : empty-buffers ( -- ) buffers lock prev BEGIN @ ?dup WHILE dup emptybuf REPEAT buffers unlock ; : flush save-buffers empty-buffers ; \ Allocating buffers 10Oct87$10000 Constant limit Variable first : allotbuffer ( -- ) first @ r0 @ - b/buf 2+ u< ?exit b/buf negate first +! first @ dup emptybuf prev @ over ! prev ! ; : freebuffer ( -- ) first @ limit b/buf - u< IF first @ backup prev BEGIN dup @ first @ - WHILE @ REPEAT first @ @ swap ! b/buf first +! THEN ; : all-buffers BEGIN first @ allotbuffer first @ = UNTIL ; | : init-buffers prev off limit first ! all-buffers ; \ endpoints of forget 01Jul86 | : |? ( nfa -- flag ) c@ $20 and ; | : forget? ( adr nfa -- flag ) \ code in heap or above adr ? name> under 1+ u< swap heap? or ; | : endpoints ( addr -- addr symb ) heap voc-link @ >r BEGIN r> @ ?dup \ through all Vocabs WHILE dup >r 4- >r \ link on returnstack BEGIN r> @ >r over 1- dup r@ u< \ until link or swap r@ 2+ name> u< and \ code under adr WHILE r@ heap? [ 2dup ] UNTIL \ search for name in heap r@ 2+ |? IF over r@ 2+ forget? IF r@ 2+ (name> 2+ umax THEN \ then update symb THEN REPEAT rdrop REPEAT ; \ remove, -words, -tasks 20Oct86 : remove ( dic sym thread - dic sym ) BEGIN dup @ ?dup \ unlink forg. words WHILE dup heap? IF 2 pick over u> ELSE 3 pick over 1+ u< THEN IF @ over ! ( unlink word) ELSE nip THEN REPEAT drop ; | : remove-words ( dic sym -- dic sym ) voc-link BEGIN @ ?dup WHILE dup >r 4- remove r> REPEAT ; | : remove-tasks ( dic -- ) up@ BEGIN 2+ dup @ up@ - WHILE 2dup @ swap here uwithin IF dup @ 2+ @ over ! 2- ELSE @ THEN REPEAT 2drop ; \ remove-vocs trim 20Oct86 07Oct87 | : remove-vocs ( dic symb -- dic symb ) voc-link remove thru.vocstack DO 2dup I @ -rot uwithin IF [ ' Forth 2+ ] Literal I ! THEN -2 +LOOP 2dup current @ -rot uwithin IF [ ' Forth 2+ ] Literal current ! THEN ; Defer custom-remove ' noop Is custom-remove | : trim ( dic symb -- ) over remove-tasks remove-vocs remove-words custom-remove heap swap - hallot dp ! 0 last ! ; \ deleting words from dict. 01Jul86 18Nov87 : clear here dup up@ trim dp ! ; : (forget ( adr --) dup heap? Abort" is symbol" endpoints trim ; : forget ' dup [ dp ] Literal @ u< Abort" protected" >name dup heap? IF name> ELSE 4- THEN (forget ; : empty [ dp ] Literal @ up@ trim [ udp ] Literal @ udp ! ; \ save bye stop? ?cr 18Nov87 : save here up@ trim voc-link @ BEGIN dup 4- @ over 2- ! @ ?dup 0= UNTIL up@ origin $100 cmove ; : bye flush empty (bye ; | : end? key #cr = IF true rdrop THEN ; : stop? ( -- flag ) key? IF end? end? THEN false ; : ?cr col c/l u> 0=exit cr ; \ in/output structure 07Jun86 | : Out: Create dup c, 2+ Does> c@ output @ + perform ; : Output: Create: Does> output ! ; 0 Out: emit Out: cr Out: type Out: del Out: page Out: at Out: at? drop : row ( -- row) at? drop ; : col ( -- col) at? nip ; | : In: Create dup c, 2+ Does> c@ input @ + perform ; : Input: Create: Does> input ! ; 0 In: key In: key? In: decode In: expect drop \ Alias only definitionen 18Nov87 Root definitions Forth : seal [ ' Root >body ] Literal off ; \ "erase" Root Vocab. ' Only Alias Only ' Forth Alias Forth ' words Alias words ' also Alias also ' definitions Alias definitions Host Target \ 'restart 'cold 22Oct86 10Oct87 Defer 'restart ' noop Is 'restart | : (restart ['] (quit Is 'quit drvinit 'restart [ errorhandler ] Literal @ errorhandler ! ['] noop Is 'abort clearstack standardi/o interpret quit ; Defer 'cold ' noop Is 'cold | : (cold origin up@ $100 cmove $80 count $50 umin >r tib r@ move r> #tib ! >in off blk off init-vocabularys init-buffers flush 'cold Onlyforth page &24 spaces logo count type cr (restart ; \ cold bootsystem 20Oct86 Code cold here >cold ! s0 lhld 6 D lxi D dad origin D lxi $3F C mvi [[ D ldax A M mov H inx D inx C dcr 0= ?] ' (cold >body IP lxi Label bootsystem s0 lhld 6 D lxi D dad UP shld user' s0 D lxi D dad M E mov H inx M D mov xchg sphl user' r0 D lxi UP lhld D dad M E mov H inx M D mov xchg RP shld $C3 ( jmp ) A mvi $30 sta wake H lxi $31 shld ( Tasker ) Next end-code \ restart boot 20Oct86 Code restart here >restart ! ' (restart >body IP lxi bootsystem jmp end-code Label boot here >boot ! \ find link to Main: s0 lhld 6 D lxi D dad H B mvx origin D lxi [[ [[ xchg H inx H inx M E mov H inx M D mov D A mov B cmp 0= ?] E A mov C cmp 0= ?] H B mvx 6 lhld 0 L mvi ' limit >body shld -$1100 D lxi D dad r0 shld \ set initial RP -$400 D lxi D dad s0 shld \ set initial SP 6 D lxi D dad xchg B H mvx D M mov H dcx E M mov \ set link to Maintask >cold 2- jmp end-code \ "search 05Mar88 Label notfound H pop H pop IPsave lhld H IP mvx False H lxi hpush jmp Code "search ( text tlen buf blen -- addr tf / ff ) IP H mvx IPsave shld D pop H pop xthl H A mov L ora notfound jz E A mov L sub A C mov D A mov H sbb A B mov notfound jc B inx D pop xthl M A mov xthl H push xchg Label scanfirst A E mov ?capital call E D mov [[ M E mov H inx B A mov C ora notfound jz B dcx ?capital call E A mov D cmp 0= ?] B D mvx B pop xchg xthl xchg H push B push D push \ "search part 2 27Nov87 Label match B dcx B A mov C ora 0<> ?[ D inx D ldax D push A E mov ?capital call E D mov M E mov H inx ?capital call E A mov D cmp D pop match jz H pop B pop D pop M A mov xthl B push H B mvx xchg scanfirst jmp ]? D pop D pop H pop D pop H dcx H push IPsave lhld H IP mvx True H lxi hpush jmp end-code \ Rest of Standard-System 04Oct87 07Oct87 2 +load \ Operating System Host ' Transient 8 + @ Transient Forth Context @ 6 + ! Target Forth also definitions Vocabulary Assembler Assembler definitions Transient Assembler >Next Constant >Next hpush Constant hpush dpush Constant dpush Target Forth also definitions : forth-83 ; \ last word in Dictionary \ System patchup 04Oct87 $EF00 r0 ! $EB00 s0 ! s0 @ 6 + origin 2+ ! \ link Maintask to itself \ s0 und r0 werden beim Booten neu an die Speichergroesse \ angepasst. Ebenso der Multi-Tasker-Link auf die Maintask here dp ! Host Tudp @ Target udp ! Host Tvoc-link @ Target voc-link ! Host move-threads \ System dependent Load-Screen 20Nov87 1 +load \ CP/M interface 2 4 +thru \ Character IO 5 7 +thru \ Default Disk IO 8 +load \ Postlude \ 9 +load \ Index \ CP/M-Interface 05Oct87Vocabulary Dos Dos definitions also Label >bios pchl Code biosa ( arg fun -- res ) 1 lhld D pop D dcx D dad D dad D dad D pop IP push D IP mvx >bios call Label back IP pop 0 H mvi A L mov Hpush jmp end-code Code bdosa ( arg fun -- res ) H pop D pop IP push L C mov 5 call back jmp end-code : bios ( arg fun -- ) biosa drop ; : bdos ( arg fun -- ) bdosa drop ; \ Character-IO Constants Character input 05Oct87 Target Dos also $08 Constant #bs $0D Constant #cr $0A Constant #lf $1B Constant #esc $09 Constant #tab $7F Constant #del $07 Constant #bel $0C Constant #ff : con! ( c -- ) 4 bios ; : (key? ( -- ? ) 0 2 biosa 0= not ; : getkey ( -- c ) 0 3 biosa ; : (key ( -- c ) BEGIN pause (key? UNTIL getkey ; \ Character output 07Oct87 UH 27Feb88 | Code ?ctrl ( c -- c' ) H pop L A mov $20 cpi cs ?[ $80 ori ]? A L mov Hpush jmp end-code : (emit ( c -- ) ?ctrl con! pause ; : (cr #cr con! #lf con! ; : (del #bs con! bl con! #bs con! ; : (at? ( -- row col ) 0 0 ; : tipp ( addr len -- ) 0 ?DO count emit LOOP drop ; Output: display [ here output ! ] (emit (cr tipp (del noop 2drop (at? ; \ Line input 04Oct87 | : backspace ( addr pos1 -- addr pos2 ) dup 0=exit (del 1- ; : (decode ( addr pos1 key -- addr pos2 ) #bs case? IF backspace exit THEN #del case? IF backspace exit THEN #cr case? IF dup span ! space exit THEN dup emit >r 2dup + r> swap c! 1+ ; : (expect ( addr len -- ) span ! 0 BEGIN span @ over u> WHILE key decode REPEAT 2drop ; Input: keyboard [ here input ! ] (key (key? (decode (expect ; \ Default Disk Interface: Constants and Primitives 18Nov87 $80 Constant b/rec b/blk b/rec / Constant rec/blk Dos definitions ' 2- | Alias dosfcb> ' 2+ | Alias >dosfcb : dos-error? ( n -- f ) $FF = ; $5C Constant fcb : reset ( -- ) 0 &13 bdos ; : openfile ( fcb -- f ) &15 bdosa dos-error? ; : closefile ( fcb -- f ) &16 bdosa dos-error? ; : dma! ( dma -- ) &26 bdos ; : rec@ ( fcb -- f ) &33 bdosa ; : rec! ( fcb -- f ) &34 bdosa ; \ Default Disk Interface: open and close 20Nov87 Target Dos also Defer drvinit Dos definitions | Variable opened : default ( -- ) opened off fcb 1+ c@ bl = ?exit $80 count here place #tib off fcb dup dosfcb> dup isfile ! fromfile ! openfile Abort" default file not found!" opened on ; ' default Is drvinit : close-default ( -- ) opened @ not ?exit fcb closefile Abort" can't close default-file!" ; ' close-default Is save-dos-buffers \ Default Disk Interface: read/write 14Feb88 Target Dos also | : rec# ( 'dosfcb -- 'rec# ) &33 + ; : (r/w ( adr blk file r/wf -- flag ) >r dup 0= Abort" no Direct Disk IO supported! " >dosfcb swap rec/blk * over rec# 0 over 2+ c! ! r> rot b/blk bounds DO I dma! 2dup IF rec@ drop ELSE rec! IF 2drop true endloop exit THEN THEN over rec# 0 over 2+ c! 1 swap +! b/rec +LOOP 2drop false ; ' (r/w Is r/w \ Postlude 20Nov87 Defer postlude | : (bye ( -- ) postlude 0 0 bdos ; | : #pages ( -- n ) here $100 - $100 u/mod swap 0=exit 1+ ; : .size ( -- ) base push decimal cr ." Size: &" #pages u. ." Pages" ; ' .size Is postlude \ index findex 20Nov87 | : range ( from to -- to+1 from ) 2dup > IF swap THEN 1+ swap ; : index ( from to --) range DO cr I 4 .r I space block c/l type stop? IF LEAVE THEN LOOP ; \ No newline at end of file diff --git a/8080/AmstradCPC/STARTUP.SCR b/8080/AmstradCPC/STARTUP.SCR new file mode 100644 index 0000000..dc51604 --- /dev/null +++ b/8080/AmstradCPC/STARTUP.SCR @@ -0,0 +1 @@ +\\ Startup: Load Standard System UH 11Nov86 Dieses File enthaelt Befehle, die aus dem File KERNEL.COM ein vollstaendiges volksFORTH machen, das mit SAVESYSTEM als File (z.B. VOLKS4th.COM) auf Disk geschrieben werden kann. \ System LOAD-Screen fuer CP/M VolksForth ( 10.02.89/KK ) include ass8080.scr include xinout.scr \ Erweiterte Ein- u. Ausgabe include terminal.scr save \ Terminal include copy.scr cr .( copy und convey geladen.) cr include savesys.scr cr .( Savesystem geladen.) cr include editor.scr cr .( Editor geladen.) cr include tools.scr cr .( Tools geladen.) cr include see.scr cr .( Decompiler geladen.) cr include tasker.scr cr .( Multitasker geladen.) cr include printer.scr cr .( Printer Interface geladen.) cr include relocate.scr cr .( Relocating geladen. ) cr .( May the volksFORTH be with you ...) cr decimal caps on editor.scr scr off r# off ( savesystem volks4th.com ) \ UH 22Oct86 \ No newline at end of file diff --git a/8080/AmstradCPC/TASKER.SCR b/8080/AmstradCPC/TASKER.SCR new file mode 100644 index 0000000..c148f80 --- /dev/null +++ b/8080/AmstradCPC/TASKER.SCR @@ -0,0 +1 @@ +\\ Multitasker 11Nov86 Dieses File enthaelt den Multitasker des volksFORTHs. Er ist ein Round-Robin-Multitasker, d.h. jede Task behaelt die Kontrolle ueber den Prozessor solange, bis sie sie ausdruecklich abgibt. Hintergrundtasks im volksFORTH koennen durch Semaphore geordnet auf den Massenspeicher und auf den Drucker zugreifen. In Verbindung mit dem Printer-Interface ist es moeglich Files im Hintergrund auszudrucken. (SPOOL) \ Multitasker Loadscreen 27Jun86 20Nov87 Onlyforth \needs multitask 1 +load 02 05 +thru \ Tasker \ stop singletask multitask 28Aug86 20Nov87 Code stop UP lhld 0 ( nop ) M mvi Label taskpause IP push RP lhld H push UP lhld 6 D lxi D dad xchg H L mov SP dad xchg E M mov H inx D M mov UP lhld H inx pchl end-code : singletask [ ' pause @ ] Literal ['] pause ! ; : multitask [ taskpause ] Literal ['] pause ! ; \ pass activate 28Aug86 : pass ( n0 ... nr-1 Taddr r -- ) BEGIN [ rot ( Trick !! ) ] swap $F7 over c! \ awake Task ( rst 6 ) r> -rot \ Stack: IP r addr 8 + >r \ s0 of Task r@ 2+ @ swap \ Stack: IP r0 r 2+ 2* \ bytes on Taskstack incl. r0 & IP r@ @ over - \ new SP dup r> 2- ! \ into Ssave swap bounds ?DO I ! 2 +LOOP ; restrict : activate ( Taddr -- ) 0 [ -rot ( Trick !! ) ] REPEAT ; restrict \ sleep wake taskerror 28Aug86 20Nov87 : sleep ( Taddr -- ) $00 ( nop ) swap c! ; : wake ( Taddr -- ) $F7 ( rst 6 ) swap c! ; | : taskerror ( string -- ) standardi/o singletask ." Task error : " count type multitask stop ; \ Task 20Nov87 : Task ( rlen slen -- ) 0 Constant here 2- >r \ addr of task constant here -rot \ here for Task dp even allot even \ allot dictionary area here r@ ! \ set task constant addr up@ here $100 cmove \ init user area here dup $C300 , \ nop-jmp opcode to sleep task up@ 2+ dup @ , ! \ link task r> , \ spare used for pointer to header dup 6 - dup , , \ ssave and s0 2dup + , \ here + rlen = r0 rot , \ dp under + dp ! 0 , \ allot rstack ['] taskerror [ ' errorhandler >body c@ ] Literal rot + ! ; \ rendezvous 's tasks 27Jun86 20Nov87 : rendezvous ( semaphoraddr -- ) dup unlock pause lock ; | : statesmart state @ IF [compile] Literal THEN ; : 's ( Taddr -- adr.of.tasks.userarea ) ' >body c@ + statesmart ; immediate : tasks ( -- ) ." Main " cr up@ dup 2+ @ BEGIN 2dup - WHILE dup 4+ @ body> >name .name dup c@ 0= ( nop ) IF ." sleeping" THEN cr 2+ @ REPEAT 2drop ; \ No newline at end of file diff --git a/8080/AmstradCPC/TERMINAL.SCR b/8080/AmstradCPC/TERMINAL.SCR new file mode 100644 index 0000000..1a93705 --- /dev/null +++ b/8080/AmstradCPC/TERMINAL.SCR @@ -0,0 +1 @@ +\\ Terminal-Anpassung 11Nov86 In diesem File wird volksFORTH an das benutzte Terminal angepasst. Ueber folgende Faehigkeiten muss das Terminal verfuegen, damit alle Moeglichkeiten von volksFORTH ausgenutzt werden koennen: curon, curoff \ Ein- bzw. Ausschalten des Cursors curleft, currite \ Cursor nach links bzw. rechts bewegen rvson, rvsoff \ Ein- bzw. Ausschalten der Inversedarstellungdark \ Loeschen des Bildschirms locate \ Positionieren des Cursors auf eine \ bestimmte Position auf dem Bildschirm \ Schneider CPC464-Terminal Anpassung UH 18Mar87 | : CPCcuron ( -- ) 3 con! ; | : CPCcuroff ( -- ) 2 con! ; | Variable reverse reverse off | : CPCrvson ( -- ) reverse @ ?exit reverse on $18 con! ; | : CPCrvsoff ( -- ) reverse @ 0= ?exit reverse off $18 con! ; | : CPCdark ( -- ) $0C con! ; | : CPClocate ( row col -- ) $1F con! 1+ con! &24 min 1+ con! ; Terminal: schneider CPCcuron CPCcuroff CPCrvson CPCrvsoff CPCdark CPClocate ; schneider page .( CPC-464 Terminal installiert. ) cr cr \ No newline at end of file diff --git a/8080/AmstradCPC/TIMES.SCR b/8080/AmstradCPC/TIMES.SCR new file mode 100644 index 0000000..c4c42c3 --- /dev/null +++ b/8080/AmstradCPC/TIMES.SCR @@ -0,0 +1 @@ +\\ Times Often: interactive loops 11Nov86 Dieses File enthaelt die Definitionen der beiden Utility-Worte TIMES, OFTEN, die interaktiv benutzt werden koennen, was normalerweise mit BEGIN WHILE ... nicht moeglich ist. Benutzung: nur interaktiv! a b ... nn times \ Wiederhole die Befehlsfolge "a b ..." nn mal, \ oder bis eine Taste gedrueckt wird, oder \ bis ein Fehler auftritt, a b ... often \ Wiederhole die Befehlsfolge "a b ..." \ so oft, bis eine Taste gedrueckt wird, oder \ bis ein Fehler auftritt. \ Times, Often 02feb86 also Forth definitions : often stop? ?exit >in off ; | Variable #times #times off : times ( n --) ?dup IF #times @ 2+ u< stop? or IF #times off exit THEN 1 #times +! ELSE stop? ?exit THEN >in off ; toss definitions \ No newline at end of file diff --git a/8080/AmstradCPC/TOOLS.SCR b/8080/AmstradCPC/TOOLS.SCR new file mode 100644 index 0000000..fceccbb --- /dev/null +++ b/8080/AmstradCPC/TOOLS.SCR @@ -0,0 +1 @@ +\\ Tools 11Nov86Dieses File enthaelt die wichtigsten Werkzeuge zur Programm- entwicklung: - den einfachen Decompiler - der DUMP-Befehl - den Tracer Der einfache Decompiler wird benutzt, um neue Defining-Words zu ueberpruefen. Der automatische Decompiler kann ja dafuer nicht benutzt werden, da ihm diese Strukturen unbekannt sind. (Benutzung: addr und dann, je nach Art: S N D L C oder B) DUMP wird zum Ausgeben von Hexdumps benutzt. (from count DUMP) Der Tracer erlaubt Einzelschrittausfuehrung von Worten. Er ist unentbehrliches Hilfsmittel bei der Fehlersuche. (Benutzung: DEBUG und END-TRACE) \ Loadscreen for simple decompiler and tracer 11Nov86 Onlyforth Vocabulary Tools Tools also definitions 01 05 +thru 06 +load \ Tracer Onlyforth : internal \ start headerless definitions 1 ?head ! ; : external \ end headerless definitions ?head off ; \ Tools for decompiling 22feb86 | : ?: dup 4 u.r ." :" ; | : @? dup @ 6 u.r ; | : c? dup c@ 3 .r ; : s ( adr - adr+ ) ?: space c? 3 spaces dup 1+ over c@ type dup c@ + 1+ even ; : n ( adr - adr+2 ) ?: @? 2 spaces dup @ >name .name 2+ ; : d ( adr n - adr+n) 2dup swap ?: swap 0 DO c? 1+ LOOP 2 spaces -rot type ; \ Tools for decompiling 22feb86 : l ( adr - adr+2 ) ?: 5 spaces @? 2+ ; : c ( adr - adr+1) 1 d ; : b ( adr - adr+1) ?: @? dup @ over + 5 u.r 2+ ; \\ : dump ( adr n -) bounds ?DO cr I 10 d drop stop? IF LEAVE THEN 10 +LOOP ; \ General Dump Utility - Output UH 07Jun86 | : .2 ( n -- ) 0 <# # # #> type space ; | : .6 ( d -- ) <# # # # # # # #> type ; | : d.2 ( addr len -- ) bounds ?DO I C@ .2 LOOP ; | : emit. ( char -- ) $7F and dup bl $7E uwithin not IF drop Ascii . THEN emit ; | : dln ( addr --- ) cr dup 6 u.r 2 spaces 8 2dup d.2 space over + 8 d.2 space $10 bounds ?DO I C@ EMIT. LOOP ; | : ?.n ( n1 n2 -- n1 ) 2dup = IF ." \/" drop ELSE 2 .r THEN space ; | : ?.a ( n1 n2 -- n1 ) 2dup = IF ." V" drop ELSE 1 .r THEN ; \ .head UH 03Jun86 | : .head ( addr len -- addr' len' ) swap dup -$10 and swap $0F and cr 8 spaces 8 0 DO I ?.n LOOP space $10 8 DO I ?.n LOOP space $10 0 DO I ?.a LOOP rot + ; \ Dump and Fill Memory Utility UH 25Aug86 Forth definitions : dump ( addr len -- ) base push hex .head bounds ?DO I dln stop? IF LEAVE THEN $10 +LOOP ; Tools definitions : du ( addr -- addr+$40 ) dup $40 dump $40 + ; : dl ( line# -- ) c/l * scr @ block + c/l dump ; Forth definitions \ Trace Loadscreen 29Jun86 Onlyforth \needs Tools Vocabulary Tools Tools also definitions 1 8 +thru Onlyforth \ clear \ don't forget END-TRACE after using DEBUG \ Variables do-trace UH 04Nov86 | Variable Wsave \ Variable for saving W | Variable \ end of trace trap range | Variable 'ip \ holds IP (preincrement!) | Variable nest? \ True if NEST shall be performed | Variable newnext \ Address of new Next for tracing | Variable #spaces \ for indenting nested trace | Variable tracing \ true if trace mode active \ install Tracer UH 18Nov87 Tools definitions | Code do-trace \ patch Next to new definition $C3 A mvi ( jmp ) >next sta newnext lhld >next 1+ shld Next end-code \ throw status on Return-Stack 29Jun86 | Create: npull rp@ count 2dup + even rp! r> swap cmove ; : npush ( addr len --) r> -rot over >r rp@ over 1+ - even dup rp! place npull >r >r ; | : oneline .status space query interpret -&82 allot rdrop ( delete quit from tracenext ) ; \ reenter tracer 04Nov86 | Code (step true H lxi tracing shld IP rpop Wsave lhld H W mvx Label fnext xchg M E mov H inx M D mov xchg pchl end-code | Create: nextstep (step ; | : (debug ( addr --) \ start tracing at addr dup ! ; \ check trace conditions 04Nov86 Label tracenext tracenext newnext ! IP ldax IP inx A L mov IP ldax IP inx A H mov xchg tracing lhld H A mov L ora fnext jz nest? 1+ lda A ana 0= ?[ lhld H A mov IP cmp fnext jc 0= ?[ L A mov IP' cmp fnext jc ]? ][ A xra nest? 1+ sta ]? \ low byte still set \ one trace condition satisfied W H mvx Wsave shld false H lxi tracing shld \ tracer display UH 25Jan88 ;c: nest? @ IF nest? off r> ip> push r THEN r@ nextstep >r input push output push standardi/o cr #spaces @ spaces dup 'ip ! 2- dup 5 u.r @ dup 6 u.r 2 spaces >name .name $1C col - 0 max spaces .s state push blk push >in push ['] 'quit >body push [ ' parser >body ] Literal push span push #tib push tib #tib @ npush r0 push rp@ r0 ! &82 allot ['] oneline Is 'quit quit ; \ DEBUG with errorchecking 28Nov86 | : traceable ( cfa -- cfa' ) recursive dup @ ['] : @ case? ?exit ['] key @ case? IF >body c@ Input @ + @ traceable exit THEN ['] type @ case? IF >body c@ Output @ + @ traceable exit THEN ['] r/w @ case? IF >body traceable exit THEN dup 1+ @ [ ' Forth @ 1+ @ ] Literal = IF nip 1+ exit THEN drop >name .name ." can't be DEBUGged" quit ; also Forth definitions : debug ( -- ) \ reads a word ' traceable (debug Tools nest? off #spaces off tracing on do-trace ; \ misc. words for tracing 28Nov86Tools definitions : nest \ trace next high-level word executed 'ip @ 2- @ traceable drop nest? on ; : unnest \ ends tracing of actual word off ; \ clears trap range : endloop \ stop tracing loop 'ip @ is curvleft ] ( size order -- ) dup 0= IF 2drop exit THEN 1- &90 right 2dup curvright over forward &90 left 2dup curvleft over forward 2dup curvleft &90 left over forward curvright &90 right ; : hilbert ( size order -- ) page 0 0 setxy 0 setheading pendown curvright ; \ No newline at end of file diff --git a/8080/AmstradCPC/TURTLE.SCR b/8080/AmstradCPC/TURTLE.SCR new file mode 100644 index 0000000..3c63275 --- /dev/null +++ b/8080/AmstradCPC/TURTLE.SCR @@ -0,0 +1 @@ +\ Turtle-Graphic UH 03Dec86 Dieses File enthaelt die Definitionen fuer eine LOGO-aehnliche Turtle-Grafik. (Siehe volksFORTH-Handbuch.) \ Turtle-Graphic 05Sep86 \needs Graphics include grafik.scr \needs sin include mathe.scr 1 $05 +thru \ Turtle Variables UH 05Sep86 Onlyforth Graphics also definitions | Variable direction &90 ( degrees ) direction ! | Variable pendown? pendown? on : heading ( -- deg ) direction @ ; : seth ( deg -- ) &360 mod direction ! ; : lt ( deg -- ) heading + seth ; : rt ( deg -- ) negate lt ; \ Turtle moves 10Oct86| : scale ( trig len -- len' ) &10000 */ &5 + &10 / ; : fd ( n -- ) heading cos over scale heading sin rot scale pendown? @ IF liner ELSE mover THEN ; : bk ( n -- ) negate fd ; : xcor ( -- x ) cursor@ drop ; : ycor ( -- y ) cursor@ nip ; : setx ( x -- ) ycor move ; : sety ( y -- ) xcor swap move ; ' move Alias setxy \ Turtle writes 05Sep86 : pd ( -- ) pendown? on ; : pu ( -- ) pendown? off ; : home ( -- ) &320 &200 setxy &90 seth pd ; : ts ( -- pen papercolour pencolour ) pendown? @ paper@ (ink drop pen@ (ink drop ; \ Farben setzen UH 05Sep86 ' ink Alias pc : bg ( color -- ) dup paper@ (ink ; ' clearwindow Alias cs : fullscreen ; : splitscreen ; \ long Names 05Sep86 ' pc Alias pencolor ' bg Alias background ' cs Alias clearscreen ' seth Alias setheading ' rt Alias right ' lt Alias left ' fd Alias forward ' bk Alias back ' pd Alias pendown ' pu Alias penup ' ts Alias turtlestate \ No newline at end of file diff --git a/8080/AmstradCPC/VDOS62KX.SCR b/8080/AmstradCPC/VDOS62KX.SCR new file mode 100644 index 0000000..b39ccfd --- /dev/null +++ b/8080/AmstradCPC/VDOS62KX.SCR @@ -0,0 +1 @@ +\ Calling ROM fuer x-Laufwerk 62K-CP/M UH 03Dec86 Dieses File enthaelt die Definitionen der Schnittstelle fuer Firmware-Aufrufe unter dem 62K-CP/M, das mit dem Vortex-X Floppylaufwerken und Speichererweiterung gefahren wird. Bei anderen Systemkonfigurationen (Standard 3" Laufwerke oder ohne Speichererweiterung) kann es sein, dass die Firmware- Aufrufe anders organisiert sein muessen. (Siehe AMSDOS.SCR) Dieses File wird von dem Grafikpaket geladen, falls der entsprechende Kommentar in GRAFIK.SCR richtig gesetzt ist. \ Calling ROM fuer x-Laufwerk 62K-CP/M UH 29Nov86 Assembler definitions $F4DB | Constant systementry $004F Constant 'start Create jumprom \ Startaddr+3 in 'start, returns like a subrout.Assembler systementry call $57 c, end-code ' 3+ Alias +org UH 29Nov86 UH 29Nov86 UH 29Nov86 UH 29Nov86 UH 29Nov86 \ No newline at end of file diff --git a/8080/AmstradCPC/VOLKS4TH.COM b/8080/AmstradCPC/VOLKS4TH.COM new file mode 100644 index 0000000000000000000000000000000000000000..ce2aa6ed52bb8d869ae3506815603254fcf3611b GIT binary patch literal 29952 zcmdtL33$}i`9J!d^Ic~WlF0&@Oh}kyvOzK-1VUI7W-=2pFv$#)Ng@!zgiJ!nBtZy* zvWQ!;Em~`}YSkYVDlN6N6*MX;W%((n1r4pXwQ7yBsI;uMZk7B$@Au3Aw!i-FbMJGX z=RVI3Wagaryk|e>J@0l-goDoU!ogD|!olg|KRak&Im?ziL3l=Z{)ejs!6fXR&|0=5 z=fX0Z@SXame%rtP)@=y&g$b*vBm16Ab!; zwa$9C&l7CP7^Sd(Fs;d7?eKZ)=eA^66lM~|MykWAGOH*y1ZFwJY(bcMu$ZYVj{w<~ z;?NgpyUHd5H887A9Oq+tvWMc?*NQ_q063V&8bvV}nAIy{1c0Ei4vJ@Q00IDnaD#Yj zW$LKQO_w!O6g33<`VQ(9cp6f zlIpp}Q{5QyOqYfZPGlxFUQz>|AeKvAoiwz;-q8nW9CJ#nde$Oos5f6ghvQf?;@Q2@ z(BMiG9>+Q*smA9G+>D~beLBJol3E?|&z|k`+y|@;Ppk%BJiAje%=(Emgw9hhaY5wGzFZz15%JJ&zKfj25*y+8CrWoX^_&h_I7mcs5<433{EgG1|o(6{bK zojPc%qSSk4J42p*%23h42b5Iyw4%B>=yxdbfgdcc6n@lPDLmR&DLm4NW~Q=33Ue2o zQ?eCd>Z0rIP0RNWrJo*J|LwkYcXsXv!btY9!X^|YsY7;DF_M{7R#r3yF&?$3Y+_Lf zMR~kHWs{03)uALwpnlgPr0AiMtU_fI9P?E)jLHe397iW&JbE4SIc@;fi@z8v8^Qecq5kGxdq4 zP7!TMV_&FJHDDtF%NIB(UONPcC+O6d+^{MPFH^EjCgC;nuzHvIr1+XSMf0h^!xUMkrL+4rRyt#cHZ+#wrn9X8RPND+);;rOM0@&xUP3zC4d~1_ z0Dbz^DC8AQES*vLA%S8@f7T2$KSjaopFa@M*6qQ^!A32Eozc|BW^bt0Tc2daHb85S zWf_OiutDB%gff_H6y2pW%Zw;)h%ycWHqOZ0GY70K@&)Z~{4P@jDT7r4ID>!{$^|Xk zqzMH|n|4xsNQ=l3?9kDy!6-G>Ij>odx~Qse8Bb$aMzekbd+YDx;HrbS8b`D58bx6K zlt6Ww4%q^TxBfW}A*4+9q*3u)6Y|u%UpIpO{9Maq|7{eVu7>x})@LphGuk4V>@B0@ z2Jm7Oc<}d17W>4gxPs35>RO}ex-JlzqI7p17E2bpWK^qoirqv*YQ$-XgfT45q`3Sb zUJcVt*z!858pBFWn^3zC$M-xF4jS4D`~b2skLk8Tw|^;+`Tjj2(osZgKoQQlLHdZH zUT3<+G*n?oh3#e!%*U zafezSe-_QjXKUl#9#FsmD}jbp71$Q}Y}_$D$35{Lmj`^|fYlhkTZin7_cYgfeZb!h z{M{-qe^|XVtYI$>ShL~_WQx&7GzmtOq?*nQQ$@dtuL*hr9%qPWea)J1jn+!jxZq4krBjPjAhvgtZdxmgrTw6 zI%C;*#KyZ5hSsTxV>;K5q4Rq2y6<d-KTRguxTt_-t<3-@5-z5t8ZY#6tiC>NK_v&Mn{a> z#HSJn_}2u(_yOz11R~AF%#bMR7#9<$zu@f><#Dk*=P@ok&zM9u4w(uPd8YD2xsfAn z0he`~UaUJ&X>`YOZc+D$w!nP(#RPLWIW78S) z-Nb`WC!XP;!Tm!oy_s_G!^9GHEKv^loYmMqe@%>lA1q;)&@9mRkkvf2Xp~^r3H*3w zHcK^LpKrWbZz~Ew-7fP=d)&babF8J~S-x2Yr$C!`i|PO=DP=yhRO<HH6Ls1p?N-<7nZIpj)jB8w3d%tbo5g?=6Bq{D;i|#< zEM>nmZ>sj!1#}v)O=pKUi(4h4h7;I+vt$o>U7>WVFoC^mmMZng-^~*s9=Enb+FlY_ z)gHF#Qt_(gB`YB$|3CVfz&>x^lq}v@=1*Ev7DyT#dh_7XWV^eLR@pC-(ZOFNql1qopFsQt#PNan zPHOks`}=Nsq!aMhlI=PEq@lI<`)_(=_KE0nBXM-_#PxQhUr4sDwqs|VNSLh19B>9{@q;l)sYB*3l6+ttwu!$_+6+d5Scq-nkhWc^OS*vRuVCI3soq(K z3?25Wlmgje_9veNX_&&+rpOH;NH@e&Okww>c$^K@UN6T>R9htC9*B64)d+iQij)H$ z{k0U%+7!KMO@VZK(@}xg{weH03M7^^HS*SPsCPIusf!(p_E$-k@89kMZQYe zk1!aH)RTx$Wm@WOg(Z5b#XQSF5KHO-0=#C=W9Ow5U@J~#(^Fj~F$mA& zOLevkSZOf!DyMQsCi1RNWs6c>El5bruS+5^bSk?cRcWdBc-&wuZcWL}ipV)qTPh`N zN)>B8*HAU)x4{1p=*Ow5+f(hWBbg*cGjZ@VwmVgELunMMdNVc2tW%r8wQrTa9nmhC z-aeapDG8ys)V;^Rj0k-v!1nWY9mN=863xd{-nId2vueTcOlPmAnw-_ujdhJaOa)MM zhVL!5Rid-7MdqP1I5P>^I#R9n*OQtHy+Q%MOVt_wk*ev_;b!dP0c(!*hFG8&~U_?1RW)kyEsi3tFSjtxQi&(egv_*(Rfaj%`v;iYZ!dEN%O-T^m5H}%_ z1HU_x4q}=j9{*kHQLS@i!ALgh%hdOfiQ?I&bHnD5t4C7G+au4ZJViDA9(-CAvy4)B zL(rE|6*6(nhAKMeCEMJBgo0XSF;F)O}_-9brYOID7Z6iUQER<%d28$QO)~=p=V_K4?uTijh zr%8$EWXsZ&TK!xcu>K6IjC1KlVy0Sv)kf6gXBfrZ>SHpctYv>nT%C3cBN!F_oirS@ z&H&GvqA7GXI@zH#nV^`$qiJ)+L<|?PPFw;gkbjVNG>t@IdnAx*GMVSBn|cnkU}eU_Uu#@hBmE@WTy5CvC4j zlTN1^1mwNx>z^MwaDTe4k*ZoxB=w+BNL!bXkYfa#29~S|qfcG(VC+tV<0WWtA&kem7W` zOpuToR$-MXilq?NFV%1RZhs;c_!f;5{o zTU9<_(*~^V>F))>RO1PDkv&el%nsj0qZ7pC`VqhqIKm`s$yA&?Do{~ zI)>FpGA?)LG<5D>_KOVG1S<@Ly3sqM|A?FQvezdPw^!XJpf5Qx);dOS<)8xCDgV>Khps z^tqzEmeEqk-++!%UZSqlJ3W5iw4%;>wT5x~p!O_!7rjn1NyIz}a`kLV-O>8obY|v z47EQ_93I&Va$m@%FB=sya%TT~MyLjmwN1?vRk%)x(*^jeE)cZ?x^=AX0 zF3ue*0`UpFEApJDnFd;y<_f<~(lD?khU6HV@4|dp`QSs9GtSiW7;aLm? zMG%^kN-dk#%X8(8?TE_hsmMx!%5hTYDHbWGEFW%adbVlw(;|fqZC8m9BiGNqWuv z%ou7J&;N8bR@y@#a&i4#olE=q1|J?pj8AHme1lqBRm^?Adb)@xQ=+?TNq<*gFHF}u zB@mOR!_q-+$!@y-2kU-xV72W?H&bnpYbjCF6Nhek;qAL@2kx@1 zeesxsA)ShjYtZRSxMz9)jZm<%fK4qSnW(X0Uql7`rRn+(-4=?sqL9kv-$4%J{CTt$?ZoLg>;i@PQFnDq4k8*4EcO$w4(Vu|wGk$K97PnBBxa z&6W%2HF}Zr>+IW;lCkJN$D(gyVvbxu@O>F^IZZ4hN8(7-sC8m(+&T5zW9&JEI2O}| zBi8KqsmCzw-;LYmq2 zIbuUKyaWWHnSDEl1?@a|e~wb9o9YLw!JK}3*t{6R+AK%E{oUf2fSw?HFNbs{Tcsc2 zo0suSNiLy8so0n7BS5hoU(S$3oX7-1imtz@UGY{pEG~CRR z>@Vw$(BV&VZ?;m{~8`4nSX-anNs{&!*d%%Xi*t z6Xvs4y9{Lz=@vTd;~-PdXA!%iL$EuyK!>ae{dT^12CPq+iIZBuHrSY6BqN*qsVjlvPXM7eZu*(;P%W469H7BYLT=q|z0celJ= zK5zVuy)d^${@DJ8y#?aQ<0xvovdK<5fQ4*IE+a&Xe8kuySLPC^Emv$L7^zD+WK}M6 zmk^*bmw3U2Y*VfQ@gv5~dWHvcS)-mz(H6EHMWRJ~6Hr|sUH2NNn(oz4;H}aVxw}<5 zfeH8NT(NpQCSaD(!iI81-}r{}Rx`qX%awfI1}u77JXxty1C)Q?%b~m%bGJappNsu- z24{FD8bt8B3(uHN<>n>SK#?&UU88xLgbrTIzQ{Gg`bA5j+A}Y&(o_a(l-QS3LLL~` zvg$nOg}@n7xHS)ir5XksI!)(_bdoACN}Pn+k{BgT=*puLXD%oiP3g6)Cl78Ku`K<0 zbS?}P!Ks8yRdlw0K@KGQQO_dwUwMkRffQLS8KW1mSMszPkOQvR+OcX8`$L|D!>uWl z{{Hi{u@UjN)P^vYtU z<|~EO{-CF7X1=b@OG=0dvipZlyp(==-1)pCY551j`GbQ*;ZGd=NX!|TPpy6Gz?%G+ z?v10I9yc*MO0s z{oof!z9xl8wrQep9*U0R_zmU|h7VjBv9^yPeT#ZFKiiZ9LaMA@(bXTeeVDJB{yaQG z&pfOS-@FWJfnB;EO23Bg|Y_+ zBrkjqj*wl_Hjx@}G4H2&yd*9pCg5z34F(y;+F7Uo7644|fOUF)fkOOSm?amgh3Jhg zdrZ&&MZvKGen^B_exXw6;wzLAdi11!prA0DRjBe6IjgfUX*3sv9tV73p%N=ATv%F2 zs4ENQXd&T3FCZQ4TZKwvz#Y}AY&@HXK~fV{qI@0f!9p{6m^s}31_v(*T*25G9qg&X zcs(Hsgjolp@{a;8{9eS2eL8%okdHtIJ5o48pQTt49Ghw)d=tiHF?x9cBTFOJ!M-e% zYkWGV@lK&>tRQu=absnlx6T{Frul6rn=w|dfo&8r*89(QvN>bpbQv<%)8JU>o-ozh z6+?ce+6G;lA%CwD9D6~c6sn7ArZsdnkM@2iyJoBj7D~_61-Qo=^0&j8AlpADsJI{L4Z6}9om1U_?UFu22jRlN z1yl-VS=U2#+y;H+i8QXPJeo#g)MhYZe8gHXVw=T&tUZFz(r(7m-y>2UT7g;CHeKK; z5%!3r40wB(pc&(`O%{Qcf2Nv`a6D2oRRwE!tx+`%48H+&#ebo3UF_qr(Akk?i<3{9 zq)Ac6Gy&>Q(u-}@R21-{9;U`paePpTZH>sP>E)<=MNQ}YIB)dsaobQ4$$taZxo7|< z&@`rn(4x>-hRumM{D>9aD$&NHsUjhVG$N|$=rF0kNwVBME`D@}$%b5KOgJ@U%0&|J z&e3N~yTGG!*$}CaD!-AcOPI^p&tX(0E_#wG2R6^)a}l)=NuKx|`#wH1r5`N&l^wzhcFBpTb_ zI_@gvN9HEopc`Qi6~j>CC;jFh9dwlLDBe*_1S`T`EEcP(ad2#MoXXv-e z{;@ez)zu3v(s7;i&c!hGus;;5+*vfLVS@hQxIThCOmj#c?DEfwg&t;iunWZL#*~g4;^ukK>KfPJbzUiZ*eHP3+t68o{u*17Y=c*Xa2(uwD4tzgkaUf z4zzL5p}f;q`!h+pqxz7n|r!vN|09yVZol+6|SN`Sh9)P;e2 zjhkV7+avx74mVd@NH30#8&@{=dnKnvH-j6nY_gjfi3gJ$3rhrPIonhsQK_d&#-$pF zXG)4UBvcW@G2+0*62tv5FmY5|7(M+(k}1Z{oCa@Id9bWh$bK>}XMzAO>w5NH3H+J$ z9!?)`xVGfrrC1T}I+T4{cSF7D*#mXs*FJ|2cilKeC=qgM#wH18({n}{l7xSz=kTVS zzOD!$hLXw_&9{u?m6(A@qzjK$*%g+n{j}DJwCqK^W{SD5d(s2f1Fe5!ZeefmM z+#^|~`(a0evUoMiE|uXK)8MQth1#j^h%6kOR=S#1mr9gxz&f^+7W!&79{`|%zUqKA z%v>tkUEszwVGUc0aCPv!bp*nj5cYvDH6i?iQpxUVs6KDaKx7LdA*buS)riP15W%K9 zZ@n3j=MZsGL`CFfgc!YmfiUm-gJzzbgURNqeYuH~(vg!#Uj0^+TyGl=%K7?O_HKR1Nc))rK03G&|rSwe+-ADj=pqjT}Bi_hv zpCE<20a$ZLD1@@LhU19>-b-^dS9ql10Wjh<~hsY10BzSE63l zJ1C1&4@j@Tgop%zn~q#M-hS&i32puv{Sdr~6_#ljHJ2ayfae{feV>=c&;8q6L0Zc~ zWso^wTRU&vD6C~YWpp=SJbWc+4TM!3`D|IKiMTpl*v5c>!M^}C;9B;*GO?x_Gv9)I zKP{872kAW90+Y&!>oJCF+3qsUAMn(Zz(d&*=axQFM)1RB#%iCx0s35?V2&lcUnaTh zoLCttnw1yvMVW;5%pyqkT)oh^i3HJcatN}Htu0gC!6woT6Qv>(>pGS>5%%aBXQK}- znmO^Dy0eUo^c{9GsOt1941@b|GbO4{v3OaWYkSt&^UZ097Sv!TIL2jfog!O>68etP!k z(te_5mG#gTpSL<#KRY`~t|jH+d22CZUr&q6<^+&Px zbRSrW8YRj~&?t-2k0-{_IwQjuKF?d@1XsBrN_FM3I|yU4tDK2ad$|_Fag~drbbYz; zvi90l9w$n-l!MQO1m<>?+ePW#a)s8l2eEuqP_F2i{jTytQTin>iblj$K2DTgD5o*i z%@(fmVo~~SIkua=Z7{0RJLQVr3Vk^z&_GMlC*>+XYf5RYB+(j|q)X){4y1u1cru5l zOomz8>2@@D<`FcN?<7eonrv(i!bv=qFfx`vNjj~XR&fpsP(e6eX_9-zDUk$ZwNH{5K6eCjF!t$ zY&=>pvh>1a&0Ft)hx2UIb$D`{t|c(Hg>UTZZMQ9H#a*ec{u{AVWGTH|yHZrR@bF|o zQl$4L%Y`)h)Xp6!{))Qh59KlEhj$>nMapR_o389$LVp)KJyO1YvPC{rPOP{hWmd?A zWQ(TaBIQp`rq8a)(4)8O8?i5{M$aygzghgD@^dPc_bMYkO_3rM`Vw;J8``J4MEvjD znJ$9lRa7V+Pu?b;nJ7rA^i+jh!bfw9N(aLT(rmcBSa_k6;?AMRXF`{vwQWoOm3bOeK(JyxS#6M(K$u zayBE9d5F_)i07rXp{tU?~Ig3Kp&~6nzFDw zQGG^NM;3riQU-YVkSuD1f#R-ml2Hjvek6%1=@ChGG)ktaQg*a|J22zqGteR@PbGz% z@c;48|NRyag&0S@R?+Jet%_*o{p#H^DQPWw_pg~&Ad?8LAQq8m7`ReCx>}Y^qh+#e znjo2^?@k5h71S;UOGJu%2VP;Xcae3 zr`1Xd1u{M>xF>Q_Jf}v=>0G~xmCh3^335zwE~@TleZ-wJlf^`Gf3qwNQu%-Gvq>!OFVA>3}0ewa%lJomkC#E+A%(<%vNWu;NqDsh}} zA)S*1|6!#>W({u4_2{U-tmH1dm%(J;^;BkLpVcedU#WWQtBK7dOY3j-Ebmu}9zRs` z)J5VNEHZH)Bxs~apH}J%7*i{xisMSgSSU=(k=#|e2<1%B*FPQpv8A}K5bD!>I#9xeU{X-+1?hhEHx*=4I6D*Dy`7kF@+ty1 zk}B0#!G}MHCjV(>b5%-(MJJnNTwYQ|g!1gnKh31>rAj}n;_MPsLIv{2a6Q%eQD}zC zDfKs1%sK5?l^~=_?^ZDvf(8UXs$$g$G6XMHF*kxDf|sh;90ZNRNXa-$qkYc@pUmbP zDv4~5LH)u+nhZafmaAIKIeTi*C@FQ8R04@E=02SR`nUtGrTk=XozW&maY6nYh<=2~5Dk3>vg+36KZ$ zAA|JrEV5w-LyZAm!dtV1Xq=a@(Q;IHJ&Mi063v1zJS++pUV@@IWRppoSCf(Mw=jT)9$7(mFivA9jY)e{8-BzK3D+THFYT zNKD)8jH~z82R*R1=ys8ZocBA4vHUlk;r&iBDUn|Db*J#UlfCXlKzZG%z3w!O7a|4McHUTn30)5)hWU3{cd_2(54#>dspggx0ylKm*F6@V8v7 z0R>R-UY7y-Aq5xf+SA{2Mn$dnoV?4I0X53Mfyk>`ql4q$Qr>g^51=6wDQS zy3!pq_tK{*HqWe-sw6mX+1#kpo&){?M4La7wmNHleF8b zSrDPalJ-3UqTn|q?I8dW`lF=%q*|=5bMADFm$YA2iwz+_D_I0)BcB0?{NmJdT)9v2t z+9+ws6s+Fsx>M3J-C{$dYp?4b31(Tb!G++1k~R?t_0GMnA4^)LTf8QS;Ljw@>lXbK z{I#To+-O>0uj^S!TkMvwqplfrF-cqI7QOYsK^I2-1_}ZyO4==MG{QaTGD_NJ1gilB zL-v4M4EO_suKkj>)h&^LKInQ$(ssH<7~2M2htPjQMrkto@0NUSs>Fo;qZy5%)2`p4 z`)=l~KkfRnq@AQLc~84umb7ySRwH;+(!QeJA^4W0DIW9=!S^IB$%Eb@cv8|vd(b-s z&q!K<2fah^ACgw)5vv0TUXrw#9;u<$=f331k+fP5?$7vqmt03M03OMw!^cV5btpRI zyyPmAw1`JUJ1@DWN!n_UIHxXf$#qcDZbh(u!6nxLNxRF#<{PxO;=s$o6 zy^Y=j81P?meIRMiP|$P9^@*e%KsrjgAZbSss=MU+Qr7-}HkQsjZ+%;kwIMVNSEA2b zk0J6m539!RqTrVv+?_seJ%FHGLzkw{TVF-kT*Cs`{~sVYx(1i9&s#4bSOAPlV1J2l zSqyq0p^>7hhLOPH;ZYX?`MUdkZ% zNA8uXXj!wx>D4%Px2Rogp=a!Da#2>ask0@nHTi53m8fX`*>aHkr&X~|PsH`8yFlIu z_K`w~Dut?;U&p*|wuCJTr7t0FbkR*6Lfhot=(5N>6hr;aY>Xu?#Z)MbHMng8Ou~TN zt<7;l-%Y#@i36l<+$EiW@l4fTpY4hI@N*yOV$1NTZ;#<=AI(-OeNO1lN%PiaX-~Jn zxBZa%gS1ml@*h8%My^~((@3Hq$7HfBM%fJRYQ}FOshU(PM~gY-98pVU8x&uy=^Af6 z_8~tM7dQnTjUMeAXI&IN75*;#Lq7uPqiPm?$~YkDCzSqFMQUoEt7XjeX{{V=YM>kUo2n#bB*EZ%x;4liP*!)*pFA(|5cg ztOEnq+r7=uDp=%uqu&+E554b5WzhPIrmfzn1>uL@gXphldf6)%k{y!P=N6R^b9KZ& z08VC0Vi$kty#O^nH!#ed5EH;f(^=qfd&Umrydcem(L*w&%;6S|N4(@M!^^x@PZ>KW zYS;K7lAeXJ^_ZS*1rkYbK)*B`nnL$<$!b8?S;&Qt28|lB8MkyvOtQcRu@#c(cBL5$ z?ief#7ton27=#nUcp|aGPS%MXm$6``pHrc9%%L0=%Ers#X4UEaJ%{4XQ`;Q4J?Qoe zj;ole=UlOpq-YmO81Y z)%4-qsNL&qZOroZbuHPx49ZAfd~BET9o<(e!~i<8zR`R^-?>*lIGd{oI=73Z@S;j) zFS=e&-+X!8;-kAkxA@+L&ey_|2}GLQTYTrP08_Mho{Bp=CrdFirNDp2NCC7izSL)I zsIIN|;Nn;Co!aYtH~Q}IJ?Pu%8}L!vkNR*MBru=1+vyW1Leh1#-R>(*)g9HG zZ4X!0{A2jCm`+_G9Rm3+(OL}`S_?@4CiKMxW9vxE@J=E3#0nR-$nH91-LAYNJ*H=P zr;uD_=%P9q)5!4Frfn0+%{&*bFndJ0VMx0)SvaPW_sAKgLaDE#-Ks(p!_&-Aa@5!D zP_m@W0X_6Q|}JdoJCipiS8@1BjBMbojM z-h``jA%Bq9P*^YUXlz0@ejt1(92ZUqCxuhON5aQZdC4dUy5Pr>*VeIn@szHD^6UTVAA?JkGCHd2qJPhWYC0>}Hj`=SSAVgct7ZTh+PL7HD08 z`(6Eb%Z>8S0JiQ~TsUB*EjKT96CB+Q*;TmbDkd-UE4=p)j@~?f^Ze732CP5Ip~I~} z-l8Vv^Lt~-p{3y!VH^B+T5a%jY!9!+1>oI12kHV4R0v@S8M1 z7WsJK{lFQ}WdWkooqmlwFuK7{@-Zg%@u$!-h0?!+7Xj#0OwrJkR!93hS`dezAXRbo z7tY9JNrLSqs`jJe3s88C@_wMz@v>h)=u|FQP+*m;NYN5DIj-1AXtPt9;ljQ1UerVV z^Kkuo9+Zs)hUx{L&UW3^`H~FdI?b|Dja|LC=0>j_o)i(ogN7?~pI54m zj}d92w$CFk*?k_;n8xT>7q`M z&BrF>2e!|n&G7GemMm>uL3wtl*Q1W})?^_rSrC}lP2=~kKLgfhgLL^?&}WSN!s&V| zWv2m_gx~7Td^XsEqvqM*yDFKF&7NLtP}_}tt5(>&Zm3`*m}oqw!`BClRn*H?$Fsqm zK{EJ!>acj}bft>O8I@~*zv<&!)!@`CYM&Pm8ozEHVa;!#KJw7T-24D>U009c@xVoF zp&9yo(PDWdw|yR&HB`(8Th*JDs`d1>cXf1y+mEAczIcjsA1T^ap>%n`x@O+H>Y!f5 zntA6ghv>LkGjEr~Q(_KT!|IM4a>XL&s{!jB4S#Lm-|rOi5KU2;zDrX>VLdH1P#-As z^YG+A8`58@@6%Iy17#t~?F~{cpWGI>P@k$pYC{}@^6pSys^_^k2HN!0$AhVW`s8}x zQ~ouf4tr`KB5|yj8d@a2Bqd=@h{Nv;=v{?qJz)KH=pcwArq%CAE-WJ5VgR~M(N+P%Tr z&{ukwFy4A2${S;inBLf|{yIc9AiXKHY_D!gYM@1$-bmbPc_VL%r;&OyVD&We(Kx23 zOmA$FsIQb#-WYAj)rIK|c|5o#^sPo3Ct3)6G0-Lt7xrVO$-CqL^3pOo(6|fVyQIB{ z6TRPyc#J-B>=;%om9LZI!5!-NaxO@GAs-JO`$p{LMuMj#?+z*rwNAIcnKvPgf$Km%-AX6oq!DG-S+^fV2K5xA{h1@Dmiffy8Nnh7mbO$DKvEb&go10FG zWFBZ%smWj0&YpL+maK1P;pQfy7OD&W@!i?D%*8uP-nyv*kL{8y-mhz&L6i4vEe+=J z;5&uG>i3$crn9vs@38u$t;%}X#(fcY>*VlzIfwCm4z(S&(QtfZySeG=AlYdRbu}7TRT!CX?58h=wmCK)XA&Zg%hAtwtI<_HQZ4Qv=ro z9v)Bdmz&8D^Fp(LvzP||q9&ftfscbi-D3sEHWT(0{`^NoOHZuVQrMMd%A!9lwSBi~H&(U8d~{FCuzdgBnTW zObscJi6xjl&*Ys2>PjhN(JkuQcIEmYeN#FS5emOlKUVK5kqyFo$Uk2vLpL@5zL~Ey zBKx%HX|*|nw03U1rurI+{oop+!m8;l7|blm^XIv%LqX7zTT{qkOMeC6YK4X+`KxO# z`xu_Lo&z6o9={jxdlA3y85AL~d{JXQ0Pq&RsZv@za0&{j(%1RAc7% zrBq|0D3AE+%g?`1Mq2(EpO(N3$?3^+=gW5Fff_DXuqJPqALp#5OUKbNdIK8+YXWx$ zE`~NVCN@6Ucsg`LXrpSd)J$I5h8FMTO-PG8rGgki@*JUcFgTANbHnPl7mzpdu)1vl9e#q8 zm7F=>0BxlJ9`0Q5;|10Q&5o~YE9N7K~d zx992=eZ8H!OChHLoP<*I4a%JhjUm6^7nSS2Q!nVT%VO}xH-)!^KL~#m{v^CD{8@M> zDs`EJjXJw!NWHL7)^j{KT3Ml-`}0&7-M6Rb30Ug)TMTYe?pS13 ziv{c~UAVorh4bWueYZ?Zv6#BEh33uG0@}989%!M=V(ObMhH9G3CtE1?Ns9rVL{tq` z;R7=YQ?v~v zwZ%MOz)DgUat+W&huRA%rb3y1ZNHt@uTc=(=apjpmy6|ZiISTZYZ*^Qe+745=x!nv z$`j*}XlUYTJM=LpDW9%$oWnIaGKnQFQzn7E)%2SA@PP@{>(DDk62HTI6)c8!P)BRQ zKtZRJTGm23O(?71Vr0;L_gZT6NU*fM*U}LUo8|~~gd9Ez`|}p&#vN(u`K-!Cx>&v54QY45de~xyWUCok&j0 z#L1ab*DV5X8NC{QH{A{rBha)Y;)J5dJQedxi})q+0qc{temmWK9#(&eS2*ag!1Tp< zs4!>uB0Mw_eKvdC1B*h}(%T`YKMtj*Ev8{FkRMvK3nwbAAo337t`V8)qky6T`eW&* z$L(GO_x+N^(|)$-rw8s^Jnmt*?7#4K$>IaIEWYtYe2?3*Xx+0E|Ni3j&*A&vgNuJv z_OnH8-8l~|!kqxL0axN5Uql2jM|gbEIXwID=%T~6hww}K{b`GLBD6!@x#$A!T;YZ1 z#hb+|7Yrvkb|NQjqsP!D@;%m9Iq4KHFGAX0Dca~OGUT4zM{rF(c13DR+eZcwh1}n!;2;6p25GWJq1rs*x)&2QRiz@djmcD_nFvTtz0d2nZ8<7;`Du zDBL34D%>XAF5Dq}OV|`8)^WljNF%gGA8on)UXu@moJNHnsLR%!{b|e~+9OtswA&G*bLD|}T2wR+ z^nx9U4q6)&O!TU+EwznLG>sdT>HkKVGZBlGNj-L4RVo|7OSR&gN=?GTga59JUjDUR zYQ0h{btlFg(Bx2zKjcH_q=a{+@c6|@T%XZddoD~hgVOZd`JfblVvt-$zQPh-ov|&p zlF!;B;8ys(?XA+6?U`y~dn}Hp7jqM%@x$$O;*dvk&N!3^_C-g-`8?gm9~F!>DBENe zbgyAj>Qh~&%kSRU_O$bChuaC8yI99++|wRQO>J9jz0^7*TC;{&D)t7?skOyYsg731ow?li7jmGvG^ZYv0R0<^>pAsOD=wTa>Fc1@4W_rCO|~|04wuL9 z^22*Jg6oeWQF|`Gyhr&k8Pjk|(i$O#^9Lv_X_Tu~Dg+hXmyxiPFcjV&l8h;xKr%h# zrRT%FY&|C&@Nl8}iCj8gST-I}Av9xqxI=$qCt3wu$-OI~Rlv)idO^Hm>ZMPv()}ir z;R}s?q`O(7?}&A`v4ovi|o#?GZFZwQ0JG2wUmDMTOK zmKHBe(ILz-c`2NM{DF;2@ea^r;U%zH`inrgqIo(pmEM5>-2O4MtX^tr!1F4Qs8Jm$ ziyXKj+yxC6!~x5erAEBY8Nyq%JnfF9u{6>0!qVFVaK9rCI7R!6T2x+s!lThNKg1Jm!xabUjdWj2;_B(OMb5#BmOn1NlSK0--SKV<*8UEt5F|@Mm)zj< zcyRLLItZDg30T=BHS4!LP%($m+cm#fnw2^t)Cw<8{Ur-%nn`dyymZ4-IG$Jd0luif!5a5nh?cu zsmoOWgk@R8xz#9X%P4ojGMO3;IQC3kD~yMe9CNXxX>cph6e8<%ByN@b*uslZJiXn; zFPms9BjND!uHMc`4nkK=uj{sFgEC`TTmbJAgAL+q%d=F7#$!Cs3Sp(tFRT)75LOFo zgd3x4YeY;ywSIruWwoRx7_7frrbY{RaCBc!U(c)-&iT;wqQuw*PzE1J7Qof0t~`=o zQiV^K{WOn6X=Bu-JKOg8vTV}_F#F1Mk(4}9=!ritLM>84H&&z7*e$|^rm9=5>b|+E zdqh=t2D8rTX1Si?v#aDGFR&^&|m3@9UFF>{~?Up8tpOUkoyHvJ*w_Bbt zenKfC6J+ZHlrS0LGTHi*Zn>cm{wW)}L$dYP-Ez?!h+!ML>t*YU-Liv6{Ic~`q>$^% zhVI$2^$$qlky_b$yc_O|{BhF_-IHYN`EJc|IbJSX4H0=l8NAvybk}X@4#?Id#7hw$ zu#S$bL`P+7HXs#I$Z{PrF_McvRpT5Rk*%Ico`?QoNO}ZDkM0Eg`^I4L-tJKUNAMOM ztXN@cENX@cKN4wHtoKD^2Ssk9$YT+uNdL<@k%&XF{xYIC^w@0_dm%y|ijhczVtqA& zLBea)w^8Ixl!oW70+Gma#rgqCqsVO(IUB+I9pLwA_f{{6U`bp5iKj$;{`%RZ1CV;C zm5Md7N5h3ayyohJVuDspkmK5WaAi1HN6_6@pwoMldi*gY;_TBSB|Xn}KhX`Rg|wa~ zl%-nd_2B6(x;_e}(^dR$LN{309?rrxbuU3|BVy}%xZ13tdtDDPu%ysh*F!sZz}nNj z5vef@pS%$m^n8;f4D?v^7?}j=NvV5!bbec=G6+Kxnou6)rAI?Jk59QNP9=lQM%`C* z5DDE}wPA7G-g8fnxp!;NK+k{oNWCy}T0dAO>w9a!I<9v?4?!w>O*(|MpfG$!)gbzv z58YD1O(%Z%WiRg~Ifh1w44*i;>FTDfzR&iT?np1ayVIGA+r5-hXuI+!$?zA+VD`50 ztC_RIE5nhH41L8Gpt2MS3qt(=nxZp$cC9Ez-5U#Ikcc@lh?tppl}G zL;-q*X=(2cbvbe^@1?Vkgd0B6bQ*G13n?l#i%)@!8VuwEV3F@GB;SFj%w#;eyKq}H zOsXt`a7?=PM(vn{R|!(ItWEYuB7f<|4FJ7=qe(WW;Eu>&@je?jug1fjES$`fq zn^e>LlRom|y4RGA&NkLmsIKkciQyKAmr(!FZAjo-GiIh zt1iLk{J%eN(eAX^s$o3DJ6>qP|J4Kw2bE{Cug_eWxzgTmzg~cY)7}Zj>%(32XCWV3 z_Smw28=?Q7{aHvs7-1cGJ)SPaj-bss=K2@azbqv)vuinVuLh-{KR$LXg)?oBEfZn@ z?p$YCFKoCh3{W6Vzc!N)y*)#ZE)m~IZ_0Ac(S NtI15iJa;YOKZrdmx|qEA7!|K zOGf(cF3^8lD;{Hx{?$yMOjK7e)F^~QZy2R4S%t^I`=;7=J6XPsi-(>+7|x?&@EP#YnHsty%feM%u3YtRI}>XivX-`2wLKKQCbhdPEpxxZJL^tfC?9Ulrfv z_swmX6sj%3E4jjqrhXv?KpY-$UDFKH4KoZg4V8u}!z=<|Sciubqr?1->^8lK9jpGm Gi2nmQPc>Bl literal 0 HcmV?d00001 diff --git a/8080/AmstradCPC/XINOUT.SCR b/8080/AmstradCPC/XINOUT.SCR new file mode 100644 index 0000000..5c47ef5 --- /dev/null +++ b/8080/AmstradCPC/XINOUT.SCR @@ -0,0 +1 @@ +\ Erweiterte I/O-Funktionen 3.80a UH 08Oct87 Dieses File enthaelt Definitionen, die eine erweiterte Bild- schirmdarstellung ermoeglichen: - Installation eines Terminals mit Hilfe des Wortes "Terminal:" - Editieren von Eingabezeilen In der Version 3.80a sind diese Teile aus dem Kern genommen worden, um diesen einfacher zu gestalten. \ Erweiterte I/O-Funktionen 3.80a LOAD-Screen UH 20Nov87 1 3 +thru \ Erweiterte Ausgabe 4 6 +thru \ Erweiterte Eingabe ' curon Is postlude \ Erweiterte Ausgabe: Terminal-Defintionen UH 08OCt87| Variable terminal : Term: ( off -- off' ) Create dup c, 2+ Does> c@ terminal @ + perform ; : Terminal: Create: Does> terminal ! ; 0 Term: curon Term: curoff Term: rvson Term: rvsoff Term: dark Term: locate drop : curleft ( -- ) at? 1- at ; : currite ( -- ) at? 1+ at ; Terminal: dumb noop noop noop noop noop 2drop ; dumb \ Erweiterte Ausgabe: Schneider 25 Zeilen UH 06Mar88 &80 Constant c/row &25 Constant c/col | Create 'at 0 , here 0 , | Constant 'row ' 'at | Alias 'col : (at ( row col -- ) c/row 1- min swap c/col 1- min swap 2dup 'at 2! locate ; : (at? ( -- row col ) 'at 2@ ; : (page ( -- ) 0 0 'at 2! dark ; : (type ( addr len -- ) dup 'col +! 0 ?DO count (emit LOOP drop ; : (emit ( c -- ) 1 'col +! (emit ; \ Erweiterte Ausgabe: UH 04Mar88 : (cr ( -- ) 'row @ 1+ 0 'at 2! (cr ; : (del ( -- ) 'col @ 0> 0=exit -1 'col +! (del ; ' (emit ' display 2+ ! ' (cr ' display 4 + ! ' (type ' display 6 + ! ' (del ' display 8 + ! ' (page ' display &10 + ! ' (at ' display &12 + ! ' (at? ' display &14 + ! \ Erweiterte Eingabe UH 08OCt87| Variable maxchars | Variable oldspan oldspan off | : redisplay ( addr pos -- ) at? 2swap under + span @ rot - type space at ; | : del ( addr pos1 -- ) dup >r + dup 1+ swap span @ r> - 1- cmove -1 span +! ; | : ins ( addr pos1 -- ) dup >r + dup dup 1+ span @ r> - cmove> bl swap c! 1 span +! ; | : (ins ( a p1 -- a p2 ) 2dup ins 2dup redisplay ; | : (del ( a p1 -- a p2 ) 2dup del 2dup redisplay ; | : (back ( a p1 -- a p2 ) 1- curleft (del ; | : (recall ( a p1 -- a p2 ) ?dup ?exit oldspan @ span ! 0 2dup redisplay ; \ Tastenbelegung fuer Zeilen-Editor Schneider UH 08Oct87: (decode ( addr pos1 key -- addr pos2 ) &243 case? IF dup span @ < 0=exit currite 1+ exit THEN &242 case? IF dup 0=exit curleft 1- exit THEN &224 case? IF dup span @ = ?exit (ins exit THEN #bs case? IF dup 0=exit (back exit THEN #del case? IF dup 0=exit (back exit THEN $10 case? IF span @ 2dup < and 0=exit (del exit THEN &252 case? IF (recall exit THEN #cr case? IF span @ dup maxchars ! oldspan ! dup at? rot span @ - - at space exit THEN dup emit >r 2dup + r> swap c! 1+ dup span @ max span ! ; : (expect ( addr len -- ) maxchars ! span off 0 BEGIN span @ maxchars @ u< WHILE key decode REPEAT 2drop ; \ Patch UH 08Oct87 : (key ( -- char ) curon BEGIN pause (key? UNTIL curoff getkey ; ' (key ' keyboard 2+ ! ' (decode ' keyboard 6 + ! ' (expect ' keyboard 8 + ! \ No newline at end of file diff --git a/8080/CPM/startup.fb b/8080/CPM/startup.fb index 0026e26..a68c375 100644 --- a/8080/CPM/startup.fb +++ b/8080/CPM/startup.fb @@ -1 +1 @@ -\\ Startup: Load Standard System UH 11Nov86 Dieses File enthaelt Befehle, die aus dem File KERNEL.COM ein vollstaendiges volksFORTH machen, das mit SAVESYSTEM als File (z.B. VOLKS4th.COM) auf Disk geschrieben werden kann. \ System LOAD-Screen fuer CP/M VolksForth UH 27Nov87include ass8080.fb include xinout.fb \ extended I/O include terminal.fb save \ Terminal include copy.fb cr .( copy and convey loaded) cr include savesys.fb cr .( Savesystem loaded) cr include editor.fb cr .( Editor loaded) cr include tools.fb cr .( Tools loaded) cr include see.fb cr .( Decompiler loaded) cr include tasker.fb cr .( Multitasker loaded) cr include printer.fb cr .( Printer Interface loaded) cr include relocate.fb cr .( Relocating loaded) cr .( May the volksFORTH be with you ...) cr decimal caps on scr off r# off savesystem volks4th.com UH 22Oct86 \ No newline at end of file +\\ Startup: Load Standard System UH 11Nov86 Dieses File enthaelt Befehle, die aus dem File KERNEL.COM ein vollstaendiges volksFORTH machen, das mit SAVESYSTEM als File (z.B. VOLKS4th.COM) auf Disk geschrieben werden kann. \ System LOAD-Screen fuer CP/M VolksForth UH 27Nov87include ass8080.fb include xinout.fb \ extended I/O \ include terminal.fb save \ Terminal include copy.fb cr .( copy and convey loaded) cr include savesys.fb cr .( Savesystem loaded) cr include editor.fb cr .( Editor loaded) cr include tools.fb cr .( Tools loaded) cr \ include see.fb cr .( Decompiler loaded) cr \ include tasker.fb cr .( Multitasker loaded) cr \ include printer.fb cr .( Printer Interface loaded) cr include relocate.fb cr .( Relocating loaded) cr .( May the volksFORTH be with you ...) cr decimal caps on scr off r# off savesystem volks4th.com UH 22Oct86 \ No newline at end of file diff --git a/8080/CPM/volks4th.com b/8080/CPM/volks4th.com index ccf8f4bbfe837472292dac04a7dd01c03ad02c47..a7d206065fadcd17c4db8d08ffbfe926e83f9aba 100644 GIT binary patch delta 6696 zcmZ8m3wRUPl^)I9(a6^V$qzsl2K>avvBA8`%fVCerW2Y+V*U$t9LPN;5(2zEvC8Qg?!70U1@}%*eGh>rv z<-U=y>}#b&3(GM*?}Lww>m^0(n^#8WlvZ=D$<1udB0ivmBf6dk%2@dp$IRA- zzJ?VIyBqQw-d1RX@pAQd9j(C+s+Gn?!I9pj`7B$h7`vBm2lipn(wS}bi?e_S>GTD*c%B$W{AuTk)0s|u+I=3GekN=baM0^ zpUpSn6&Q{#7j5E%mjQIUXp<(qHb8Zv%|GE~0X2&@dBV#9>JV*;#p@PXrOYDUCE8jn z;y;UQ3n-EKuVRW-G>iLfkyErO@*|?He!@$DaZt1cC%inMpNY1n39lW{FGWs^fHTA| zh-?HLApEUpiy%sS@5sv+D?O*PJaLjQGURiLfcAzp^Z%Kw=AUC*ss-Sa z&^JUbq-x`UsUmUpL492OCqi|J^(*7zbwax&RtEGjp}i6p4oc&qKk`XQ2V&}9HGY~ zHVo(_p{G#^o_|Z|YoG-52SVSHIH}1uE-oSTU5Sh6pj}1i`=|w2ODLQ2lZb}heMsmG zKWWtw|Ao*zKNr^2aq&$;OA*TB;{Os_?PtSHBGR|xF}w+P=O^lq7x zG=QHFdcRB}^{Jr0Mk*ro8#0l6!C;Ma8m0gusz-eVq5HwN?yHfO5&C19gFtJfwS@j$ z<{Fx`8flc!=KzM{Sn~11CTg++6y_CvZolr(;We>NsXDB(wRAq z4FS8Aiagy5mY8zOV(Kv?d3q?o1zV>rE+JpUtmNtQ0k)$f?JYHhKLps?&a`*h_BM!M z%NI+<0l}jGJsRL@vB8G{50CAII<~VG+k5!iOdoSVVLEgP1HuW}!{^r_uN>6i`h<)^ zZ5`K%txm{jw9}xmAdr`$@j7muv^MP>5PI3~$(!p27NGH~btELW!ua1`fvxRyZyg`T zO`7)Bvi~LjSbW1@#vc`p03w%wsFvMpGWXXJNJ`Bj9uS%ux)Yih#^-kp6_t|{%ez)Q4A%u^m@ zr+>=q4B?!QK~zh^D%?^U!#STpDJ7|Jm3d&`3^SXV@V=&S&KDJ~+z0(Uue1oi$nfz0 zJ@s5=KdYQ4cPZ%VfN&O*V{DEm+@znYh*xp zh*HMmZe03Ps?rPvHaO?31d`mOK%Ya<^crbg3YVEvYv9VIaN7GvWsu-TN2i^prKf?E z`*9<1d~c3owE_7-jtzNTa~np)mT1{wxQPu4I*VsY)x zoecuGv-aJKg6=G&*-RPVlQl@TgYWMsF5wcFKw;hu>e4yt>yuEJCx?NJ!VCI@!(a@D0OfxbJ5t1LJd1W9?L+?MuMD!rv2R2R~ZCf6!i zFmEhzllA z4|9OSMRYT(?5Bf6!jN#qj+XP~*u8CLUyz_*T*^;^sE9WiE1HUmO~J9XiAH=eInov} zgV-Kqro_(#VRt$hs5{|fbN^?P@mSORd5%9cWypR-SHotrgH4PjeKvNxGXq*+GdBCf zCW8&##;yq&OG1k(dO|{2)`C6>c43@XBs){OHaTmsJgtScAqU1PsR8)Pns#C*( zC96!)B_Im>(NJPNPSPa{og*J0{v%%Od|Xpnrr1Sa4@c=nnkbZSk^ZQP{5 z*l=6ud3@S?L;I5uGCkhVuHHg}8I0nwD|(Nwf8dW^5JYFQ|8g_L-XF5sQIshXiq|^*_`LrnM-% z541u4R05r@hB?Yv^Z8%Mm?Ja9n5^){QrHPpT+>-0&q306~#T=T|NQJb*6Nf)J6vh zE`4ou7@osq9mtP>ybk2)9JScftZA#Y4U*v@;oC*mh_(5W;WM9=XjqD(At$@q*cJ6| zJO<7&x@7o7w2ViGdmP`f_O`)3e+81q&fJV% z;+jBe5iq>9$_rYha=a3+#hX#%<7m;msIpc$+FYkpnhlfT^W~F*GltG8l{#Z>tju#W z`q}x|AG3lQj2ZXE3fXkb_~qf1aPwG`5s%$k;dI3;n=m$+m&XB8qBTx{!^Ct^lT zOFp}%#b|F?lCqMr68d~rI0${dTvf*Jt-c0>&%%?VdAD$}$S!`lJ9%f}y6hZB_?iRz zc%aDg=0ETEKX-Uv16wNxGtjbe|ZM^}KQQAL(PDDf#^@8+h8SEwq5Kme7ZG@S#b22+E#eI zbvBcimne?CI$FgR=g&HJd#bH4M~4e^!n+er`i?d$%b#{HiwqJdqR7)QY0DzRq^qrr zAB+vdWL*^y?+1Kv3J*Yrod?E%Pz6uiK9iH?t#PUPP}^1WQa#i*2uHNFdM;Q!yu)@E zA8PxP&opmtdqKmc6eE3PdD|Ltqzy|bTp(wL}aEFJ-GK4at9ae3D><9P_P(yIJIdPoW!yP#ees^)Y0~>R> z>*6*k?adw%=EPCd;x^Ih$Ec3W?0s?LtMN7Se;B{FI0z*HR7eP+h+0D*f@=Q?jgz0p zjaTBEY))foXHLr5iDiY!u;REv7n!O!w1zk5+=n~x?F-(A&#@;94(3Xo=x7!=`h6Ua zMZ!Ed1H7L#t0H@DBF_4wSY^RC3_t2Lzh*!ur#e|bjAX2&bSAFJ1Lat({HT*5Tim%n z=;T7{;kBrYFXQn|CC(qYYU441M9$YJ=B0uP)n4>qyo%1H-&+cTx^ z@}Pg4Bc9Bh{wCgh$?EA~rsb&@L}8Bke}GKmr(gLE`&81{es9Ut{Xg=OW)T1Y delta 11638 zcmZuX3t&{$m3Q8|?~_Mh1`=TMAYt->86X1z)5cFE%r}{2GV?N@d>|hZG9k&#Bq0g5 zR@=c{yU+^QGL>2?QsWkd3SEQ7N)fH7_yY=db*pGgZApa|4Y>X#d(L|^$hw;l-uc~g z&pr2^d(XM=ZG29*@w~2>9JMVaN5_|tqc<)6_-Nfw4*ZaJ$@p^{2$9H94#@Q;`M>BlR%q(Qel^Bl|E$S`3gl*7M!(5Jh1nl39juFqqK)($488%mQVL&lV4 z%y|R5!s83&e3DcQMqSpy9>a)EXFQlW<7t+8al^smGpBOQ{<+CB@+tblhLH^iADweu zhW?EWt;`$qsS^PDESNjR?eV(6ZcX4PD@h7h1s=U#PJU4#C00N_vB z#FIAZq%D&be`V9zCS-xI;(yz8_6ZsKXT?dI&M_hD0LrlIoD(twP?lZinvhw5a_u?~ z2m)lbGaj=hxXi9=&;-lvOal;6(hYn?6Roqe9wjB)Y}Zvy$P@&+?KGICj>IDgvz!+FQ{ ze}vyj*v^7ZD(D)dXb8EBM~(Jo{B#MB0&E|#ea9Oj#}G(`%)?%aInD;P|K+J zBvJvapyG258dR{mPpNnkx(gxvE*0MbZHj-t{m)b!N6@w3{&y-~0>!n7{q|3&_@#q& z+Ca0Jih`51Ih{xB8>u)0LB|pMW-8`7*>J%#e)X6G-<&^z*R2*?qB^<0eWq+QE`<*Q89;fWbzyl}@>NxO#lX{)l ziv%73JHnw0_Se7xPR8TAV1J8>=WtA(3-%YN_yK^91i&Y#_&JUbz}KnByI_0(zC*?7 zE*Kwx=cqW>1>*zoA{EUp7$1NiQE|D8btnK{q2kRh8m#gB}Kb;x$bzMP6N7Yl}7u_tb%;n3$ccX7)O)USRC)qKk`sH} zthX`E(hKjXQOSw_>Sk829+SsanVoK?qGe1@^Bw{ec< zgqT;!-sHG(Ox`W@Fsoe)D|gRB<_(q9=W2xUe_V>KdC_0V1#pp$$ra2xSIoZ4Y34TC z!)}E10zwsxUzJ=_Ng*l~O>m>#%jpFa+vMD6H*y-37X4vm4!EvyOfKWYZoOaxQ4}Fm z5UZ2ZDra9Wo~(4;geM5v_l?X~48_LDSwEQfw^9`OdnLcZYqPt&V{*jMW9-Z^a$60@ zgyigTTe79HI3dz1F2x_WO|8O4I^J6)HF|syK-!_U%0@I)Jzn8hT=@!ll^iE0)I$*e zt5}Kub3}cRP>!jVk=9gkAy=Rly!N$&YIjxopkk!NFRL<8%Hy+nL2`$zZuYyY@PuQe zm#a8OIN2?|26-gbD7!iZVv1rKLYY?bO%?iNt8NR@m8=%FSB=w@z*=Mvp5Y?mZrG}J8H zFZrbmSn;g%KFGLgJ<#V~XnBd&EQ7;M%Bp59j=-3FpJ#;P%150oDraFewHTbZGIjv( zH(~)jE$m4C#IvDnq`Hjns>b8CjNf<_ZV+sqKWJ1glXg^((5~sDV2LKnOOE8q>fG!G zk6t*(W{Fv$%zP=6n7IOKORldrw!Bz}AHaxFS1VZC zA!66BTF+Sp=^v9gmxA<{8fvL=HI2#dSM|*Qq$FSZZ1T&h>EIq6pY6>|uS_ir`m0Eq zpk;@K-{Gpi`UB~lmfZ0~&G8_8xk1_vKDa0~({m*_QRq^mVZe*e*O?bhPi5~Go-VW$ z{k~A6?I}4|k|nM_SAqh+@RDp=vHTm|cdGJfH1-wBl*O+>5+&DS%d7A7ViV@3sn9) z5P!0}cHttcUkJDqugw90*vxIuxI+(tH>1(d*}XPj&6wO(Xf+_E&!7BlZ85XapM0-& zuKs|Z*LuBo?!KmdP04KE(rKB>*@f!Q(PGA^BDul8cb-d^Z|F&O~)SjmW?YVbt z3Mf~yL<6VS3-Fjf4V7pDNEc`7kML&hgqTXRH4YkHSs3H=3vjF3S)i3C+ZE(a$a>fi zbr1_?uBa{<^_%rYb-43piMKDZe#;892mCXA7N8Z^)z%f)Y2)iqjGU#esO}<f7ixGqVR!c0q@n=h(sw@Qjr zNnWSSFJS^tsr=v6jZh|#C2}a7m(2y&4i=hF=P_Yj(KB^fqJ)gYb;-@jlI-(!>A0O4 zSRX*g`IO|#%7U5bbsV&tA20eD>?|hItDH}Ab@|NWfuyCbaPb!bIH(Oyb#lDi9^S~| zY8jIsuEPj11QGrs&`dMw7s*@dmL$FiOau-JpHBbKYV_cih3#W-D8Sw{e}v`=X6|jF zT=+np=6?--U$y1ox=i|j<(WE^+7$!?Qqbk1UIh<`i_%y2Tk0;uGAUPGfTO*y=;6Ab z@cEKJ^0Ju?eN*$Y#dv>bPghT*(-KUU1ZF1=*S#&wRQowx_rX=&d!Dgq5W4FYb>TIJ_NrrVRJJR(_%--D${yfn_z$X_ zQRNnFoshQ%uo*Z{`KG^7Rk$UjiD2WsLPo0jbIKl-`(B_Cs9tV6$Yb}1LtTZ9N{niq zWQ3aOVVHY#|KX5Ee-)xDl*2*7J|=${Itp7Bw)-sfWpImFeYU_5>* z8)C8VD4&JKi|){m7kwDIq)rYEA66rjhE<~>0*~;>`z(aEYg7JV^6p?xVryVas3MH^ zr+d6LobE9ZZV)~U<-(HQB0{%oyW0n^?Y2>Arim~NM7TAqb^C)bnm#7~Agm4jw8}|@ zn<)+qIk$#!rp^{jPbo{NgNVcjhHrf@a5(gG7`=jlqXiE}Ma1$OnAp?vM=4)FLUEDs z^`r0{r3~OZ0cQYD2e>AkmP&KAWnl^K749y$M73pV37!`2&b|hf>XDH(vQ`f?Mm8e-34@MCOFNEo)4kgk0ij=<~}eBjiD2auWo`35YhH9IZdc)&kZbpgmt! z-BtH~)$_&qaIPG!PnL!Ya*duZtG*wQJnvU&y3bf9h1cp)+51&eawu$09Ie0B0g(pH zik{TdXjlomgYNb$QQ2hO!*41?HCx!2^$`2rhBDZf4zYRx)`3;cRXDWi5F4ZI)(3&F zcBuwju7LX;%I9TET|IrBH{uC;`-XFqMwttrz*+&|Tjb;w*#QhK#76#+@ z12~0GHEx1YQSwG3?qh=V`Xr&o8N2G7$=e#{=_{IOA>^tPa)RW{*jS(3+fbb7YvKwa zd4no;9+79<*EGfE2zmUzkj?IOg>puf=aj?Bt4dk;*>Es?CcHF!DEwFmfA@r54c!vD zKV%B^hUV7&LHUO=rRkoaJLC&JP~TYJRX@-?wT6&IoOu^e|8D*72fE zg?+2uPN+x0l2v!r;iP4RV)V178^9{eZgGOJAv$z$)mM$P#93~bWyyo9+vvHvwsA_b z%JBH!E&MVACuU|q+sY?}U8}SW{)tt%!4sM{qrFK7MLr}f8C+@b%T-HOHCVr_x~=Z} zYLmPfS*vxho$eKW=to7R%IwvI&YQ7pwUkQLLatgo`aTdo4Spc}%7?ZtSyemzMN?N{ zMV8U9p+PV3hOR<k9}>piZ9F?r`|9A$So5>3BnPM#%5?rn1TtKB8h* zQ{9b6$#dj+@&Y+VUL-G(ms4q?L^i4kurAxw%&9Hzoy(PWmv+CEd}vh(KhQi}cvo}s z?NxH(XU#g_m^{$@z2<|$rb06}LQmzi$+<9tO!m{wIww|IMsA?l2uVp79Nc#`>jg|a zPkel>p(L^^rph^HDhBon{ClK(AR%zM$FivvuoX87hXtCK=`(z+~h5* z%NScr^4F_x$m?ktF4Q<8f{^8XRi%8lCCN8;B>vEXeXBf3^w6G*(ls>A#Ea5|D%K3W zz~x8wnr5t*;YtGwn?2c6T2bvxXn9`??#poFJr(+T4HTpFf)>UZ#-tE#iDIqlRS}Yt zt&G!qGv=}Lr{QdEvtWJ|YyE1YPM=uXb8}l7|6A*dqsy(#qCY0Lwd6AUT9f-*@^qJz zueQvwRJP?$P8OVPU1Vc?h3>)v8?)&7)=qbNxB|`Gv829rX5y7rT;mek zFR|+`EIQkI`{OS+x83-9>qE~z+qUSX*1~TeezUpl*4D9dEt;H;6yo_T4Ap zdGv+0UoU^XwIf>ad}}@-(C6_e^I9v$VF7uq^#kES_LbHbO~>F5_5q>0?Ja=z3U9Su zqFdNQY)9LcS?mP3@2~I|C@8hQ1x<0eoJ>C18k#x1Z4~G+c9a>VSz_Qe!=$jREm_c3 zvUKyBbL^zB(mF!5^0`88rhjFy0vn+k@BIZDPb3xc=Hwl1HzXphoYQ3wSB}ZOd7IaC zw{uEI0kWP9k|8pj3e+j& z88uKRSmgi5RYFH@czm&zvC zfw#a3Nr}A!@zkxAkt>Ba5BLIROny(h$igVx#^L`MGkGKz5&=9M;Pg%qGoQg-gj!>_ z@S~|1Z&?4PS2Lag{QPN;8MH%Xv;(7kOdjnhSD*X9meGz;YUU7n8X&9>aJ~^g2KZiK zUuqOy&d8mF_GZ-%H*7Px(B-}a2sS{nP(r+5#nXUkL;BHFGvLPnM>8|Yq;M?rqJ*8D z7BG0x$}!lv@Wu!sGgl7xk!H@n7H?N3g?Q%44qS}#)X!Dte4YQ(6hFaS6+p{B?>Mbm ztc@=hDkp8^Xt%xt>lB`x5YMs2F#d0K=t-71DM0NafmgH778Dyv_I7E%^cw6fPt1G8 z(AiN8wNlgCTi50a``7MY`vm;u0;OCyA>#kw%>>xKuj2!u0!A=GkFR}yE!MTq7l)y% zi<4Rviq71vI{doM?UEPvGW3g=L(kj@7<$di;k{BZV55MUxk=%tnYggf6PHBPW+30} zfHE^w!Sylmd?s`U6w#aH#> zjC^&vq_Hv>TfQ_EN z7E_y?!JT98E7E2j^;;sj!p)s&ycvo~eG31m(`YE;S3-SXun07|c})yz%$rOnQY!}S zOJEN&fk+fr_QG(mGikNMU#q~2+ZNN`JGFKnbz*lBK|3xr+TT0VTzf~GTnsUx(Z30p z{TeLIMKkRkA9WT(6r?3TN_5&&=(jpJ63;xA`O{2hsywx`<5c9I@cSqD#fAr9R&i$c z3I`yd&^1PGcGvu_^w{+s`BIiP6;8h^xWZH{2&$ub^-f+Lb7x05;)-0?bzRrz5&ZFY zMIwpMBN<&8UAIRLMvg@`rMkl9_~TArhqfed?fPm-o=+`F3oO}U;AeI2QcXCO(+o!W zI^V5BqEMP4@R z88TJK5FzVO!ptSGXB?-OtB^6EW{?anFFV83Gh}k~cScO-SmdI6d9rxjITpE7fVrVB z+SmWBKD8q=w8g%mox|^g_iMh83H7FosJ8_?SPXp4UbRi)D}!+XjL8#nD5rVOGjlpS zGS(em_uje{>mutmfw9@MOzSucx&G)8$ z6tV?tT&YXPx7vw@rVpv>pCU&{;_1|xga?y$Z=6Z4S5GO%*x3y)O#RA%?nPeao8);& zT>b{obe`l~h~02usBjRl!uJ^CFT16n$5#pE4)llBvXz+>dZ2!XywZ5QJEJ!24SCYM zgWYK!YdqhbxKn{I72rA=GO&-m946P>02JLkW+J%1<3Uk6?GTGov=hJE3Qd zI3@=Q-t5lHo*HT&ike{I^beYDG+~YMQTHR=@M6w*M-SD;v0Hc#-eg6DEo{WFjl0bd zF&u)bqz14_f#~kgM+~?JlcQS=H82XCsIBlN#e?itpu?Gp1KA3nSd=B;6(oFV0myeD zfj!LNn~bfXBiREr66Un%MBey#j}(A(#UG+Y4z1Y*wuJr zaj)GB0=;>dd%1a6FA~GO99j)@h@9H?o<38lwFcHTxHkdsH}C87Rh~`UwnS`2SO$mCa6TW6ieZ5g0MFnM1 z7G6chqe48INW`O4c{Ou^?b;qL;BX5Z^Zh$i5QGGl*l9Ra@XVs7@PM#5iZ#}|+pr_vTNVJrb=fy+_40`L;R$K>kR1FE5Zpp>O3_p6llSdrp!*cxJ-JQSOsaCzZ{V`U7|$!IzJ z{x5%Nqft@icFQ19=Ruy{` zvGXzfnqy}y5#;4hV&Esm6?ilT2pi`XD*?ZhB#+MrnVvUPF35?=8l_25_3L{FUe`GE`> ze`TyWelGgQXqK4iir)#!1UV7saYf?W%xkma@+c&>aVKN4Tj_xt!?0AdgpJ9KeVgMz zNyxE2NhRS41#dOFpcMa}J_Bz)wL4kume?OM1@G_c6T;xW%GfbDs^KJ8+Sf%)zJAlx z*v`HY*oM~?Wr**ABzsT{ee)`_1Bp?;o4e-t(B3XNGvu4cfno5rbxXB>L0j8 zXegIsdxf2SmuL@6>zKUFg0<0IeVEE??{rRx>7)&>hp9eTd)Rmn-1gpDt-OL6f~)0uBQ#k9YJ#i2&1wT`yUZ%H zPm`jfG^PF;?Tb^|4XXBwk`%>4G4ZvI^aJPxtt0(Fx}(Pj1g|F;f*eB)Y3QRtcxHgm z-&%JI_XrsrR)bUJ-1S0Gf$K9@U_!1NTEi(}uh%s0f80dK`8DDa$jd_EAP^n}!p8NY z#qAtkpKyhMa$zwcBkOsm3!H;3;L@ajy#x&$HEvCb0BsJeXFb^dy?KNjUJut6?h3$; z0d`_NBz|hi5CBRYP%f{}RF6jZ_7rXofLH`Xeo&}Tl>*)b3g2BXC9X;VZ3f7^wMI~E z0nBd4{RHrr*JQxQO>RGIok01QrSO%@;546q3EoJ++j2-Zf&BYCh}FSNAJ~eywXYHl zI{?J?LA7!k_wN8?c<`FaX59a8KzcHenf6+DET0Nc~J8EyiMws0fOToxNwL=5@5#x`}Z|mzzz@*)_TUSsfdS0>bbNR?GyUzWmh7DDC22zH8{J+KCD;DURzJ?2 zmfW}ICFZf= Date: Thu, 18 Aug 2022 13:30:43 +0200 Subject: [PATCH 20/21] 8086 "bare-metal" Disk script --- 8086/pc-baremetal/bootdisk/flp144.bin | Bin 0 -> 512 bytes 8086/pc-baremetal/bootdisk/mkimg144 | Bin 0 -> 52016 bytes 2 files changed, 0 insertions(+), 0 deletions(-) create mode 100644 8086/pc-baremetal/bootdisk/flp144.bin create mode 100755 8086/pc-baremetal/bootdisk/mkimg144 diff --git a/8086/pc-baremetal/bootdisk/flp144.bin b/8086/pc-baremetal/bootdisk/flp144.bin new file mode 100644 index 0000000000000000000000000000000000000000..f6f3fbe22df3b879760bb832a986f1bc44d279a7 GIT binary patch literal 512 zcmaEDGr=i8za*e2Kb?Vzk&%Jv0fPhg2Tled1||js&~!0Y67=&|@N@KaRR97v#}Gp! zApPg8(7^|6%`X)C4(K*8^j+A)z_F8oaUVmC;s3t-pO>;_C7$M!?+{aASjf$A@C8dZ zpBTgUhdtLdkM|unyuDC{p<7IjftihuLGad#FASZBJFo9hVCXgzWcdE_FWQ%tAm4MN(T;(^H>yOi`Gr8=fxa7k7Yv`UWiT+lHf3hx zVCd#!W9XKXV0bLlZQmWv#CS-q?-nDgeDh(JNAEfhGt2QY^j+>&699Trj3MB^nFxbk z7ceyT{k7l!wtnx&|ECl7voa)nHART}L&wnrPuMsfc3cA~+`-6nR=AkU z;K^CxME}xjuZ0plOL&;&xEY!cFg9OeczrPO@VgR@tMJUV7KPbcl7>qn}=N;bM`OVz9bLTf-S2>b-`Q6{0pU0TP#TawqEyt^VfUz|5AjjB; z@Tzz_#!YaEU*fmI&=h z2mn!RuX{NLgYq{ov2+NR%&HUUErgmDPb6F7`J!Tbx7S+s+J%OV?FOa7-mHIQPwNPE zc86k6Dz^8uuy;flAWXdHp9}nJjVEH^$PS@UY;V^(%fE6l34{xuIkr)uX|2&ne3rms zdjmIG_9}!C!gKg5G|ufMBfGny+Qbx|y7{nAS`&>GgX9nslQ5`KSsq|2W=tGz&cz1bX48Tr)@rTY}qP>2rIk!(X><4?5iKWepG_5U|2->w5`q$q( z%L!=_F0@Bwg^#AS#AkQIh4uz}#dz%jp>aW$^FP;KYqYB?8nMfY`5WA4+1qMwp#R3+ z?0MAKu<>TUufbke!$tD|Oi$$kOVYZa*M6=5vy}vf87qY-h2$7{da8#Rn})0$Ve9}F zEdFCl@J>I=7`80iI?mWh6q5NSy!6;}eHHRo<1L&gsxN%T#~Ax$VS&gmg7n~Bh<9Z& z9$VQNZduv3x3dkHo{!)qKVB_=aOp!&RoDFE@waZS_}4#;T!%6bUTci-%CUgw`COL< zo#an`ts}n-<0m^!YmgK?)NeIjs-rPG)-J^H>zMTg{%qbGPlUQwtX~1Y!Yxq3b0uD~ ze-iw7AaU$+Onk{lG9Vd{3`hnf1CjyBfMh^2AQ_MhNCqSWk^#wpWI!??8ITM}1|$QL z0m*=5Kr$d1kPJu$BmQE#4Z%zU#Fl>z;Z^2W@z za>!Een74$!spTDW&=d=k{RB{11G~Fg1-K&^N!( z`Xa0KD}P4o)N|$Ao^4-Yw^c5$v)kwW(VM4imyG5q^HErXQ`{%p;*0PN{(RZ82w!F` zwhvq|KE2tr3^rq|0rMDm^)kwn&>rE%WeKEtA_Q_suP$+S`j&O z6}qQc6zc#b6})6dNtan2PeZV*4|Ku{lUPM_G=(pw`8L*X)$_Xl6m0YdUQ^PmsSz1| zf!Cy_XOsty_rBp!4jnJhx|FmIBcaEm*7!~3TO(+HkN>p;4kbZhK4hc9SSE-aY@uai)}13I?PP;r4Tebih72l>c9#yf(` zf5S^~^w4(+`HFEtow^3L3g(#4K15U>Mncb*_%QOUQBjs}4RXs(yulQ?S-BUwk^>oaJm2hOE>&S8!|Ohz*9AE4eSO}*|&y@Ntd)nN{E8sCGAy&zR?fvQIg<$nO~U>Hagmoer0G z#B|`D?{fj842P4?@SpLHOwRY~!#?nL4K4Ldt&baYZzF?7`7!$Lr8$Huj59Utz=*Ru z!2}dP0>!Ggk8p*bU~P#*!agJN=L^PvJI35|ZY~AW`4R8)STwusHN(LoY2pF$>POjQb_%Vd~xhfkp)u zQBI$rAaAtlQ9eDjk3jH=UPSBJr;q!wYnxB|^cT)n zc^#Nf|2aA|Rino6pTivMI3*1KY5lnAdza6iwQkCGk#VEKn&#)JN?a25`QiaBAGQ3w zj(5HIdJ?#Vj4JMWuIg<%3iUtHDRK4&{e)MaXc(DvH=_H1W26!5CSc&ctOyuQr2+kx zQb@pC$^%B-l7Q}AVpOD#JBWd^H{?fe{?uah8Jdt%%qC}a&W%Cq%e%#UySLeU+h#R2 zwFHiCy%nzUYnZ+nje?t~z^KLsxd&%}d3c(Sy@pD4{{&9n32WqEdIuFo&xH9VG_n{j zHNKcPF58Tjs;;_JqwE$ddriBscq6jydeilF_pI_GTi4&c3JPm2h0lz#-;UNf){fRW z2S)4Gof)mW5xDNps!{vh0NGx385GUs+?}%DTfBbz7G86j)BAz;vGog>b98-~1Gz;G zHoCstiCo1bLwZTwg3Rle)5 zs7Te|{KUo1aBYm4)fZ8hWy{gC?!5{_zMT6|wjDmSkM*9%_G*3v%R|-2ES|m(kE>{( zt>ZqI{hge&xvxi+uV#k{|TzPQP+!L%CmfVAFVw)n4Ubjn^^l*XMc1{QT?T zUggOzRCx8ZpY$4d^>Ym)r`-*G&(R6fFfujYr(fwcZgj2l>g&A9p)Zu_HAcke$LC7<2>l#D9UGxr z%RGzUYQTYMgYdbdW_8mk=EPI8q`BcJLyiT;)%hxkn&p^Y7w zBDHR{ll zrrP>$e+kalDQ<8o`y$RP>#nlG?==_)!rlA-#81_t2*EmE`=$nQzp94&JakpViYWA> zhbf9RxHz^FPMA7=l%neCp@QL?Wg(QiQT!H73qlcqu? zWrZ;u2&>tTTa7Fe>Gx4UJy{hB3Ck)u%2$!s;td_;i|$nJqu*i_7J*&*l}BL_XkJ!W zq#_7ft)wrVEwf`SYY4Un`)EPf;}X$WdJo(YF&g&+gQFs-agj;>4kd%Ul!vI8WH{ZwaE zDF-X{xAmM_b6ok#Vm{y}4x<8Q-S8EQ>oYl^)KSaQz7LX0#(f7&7^QIU4WoSIH|6bm z^C|07LOV{2k6()P-`IBB+fUPY5m1)xwCcP_+i;)Y>k#e)rq!Bp zB~8ba+V>otB-@@f%Zcm-v+?Gb{~XyD|7w5}9w#+UwW&2Y|1*8op`KH5%&W%QacqKT zL9TfTjPTD=xOzz$Cmh#b4~Q+0GXhik3lz5DLx1ZZ)v=NsDtL|BnuMj2oT|Hz_zH@I zO4flMvp>r#=eylR-9Cg$-Yufi!fySfpKtg(`Ds?L6u5<~{V&3wIB;TP? zGOipePrZAsVx6Oz+Pl#OHmg2`RZse}cSam{hFOJGQ#3I*Kr3%BwRRi_Iqjc(5$4J~ zf?%P@+)=vjA3KY^Gi(L&GfTgNIh$GfJ)R!m=_5S-5l?^2(;=Qd#?!}ndWffod3uDW zPxJH`PltJWoTtwrMRfKr5Z=u*OKY8s4Rp{Tvv0zg4m!xQrzl6vW=~MAnsVcmtEb#C z%Hdx>SoU$sZKvELlNpJG0L@3?nTPo zNx9c3NBHDdcJ)eL`*&a;uOnLUsyiQ(^!A>}@QiWI!??8ITM}1|$QL0m*=5Kr$d1 zkPJu$Bme}{pwxK53qP2u0Z6Op9FLA3ySEwrCFN z$4iT>v5w?pQd%EvP`27o^w()SXPkDZdr@Sg0$yi|cI%iYH>N9W;P=hd^E3gt{$cSMC8! zgu8gNUI)Og?pQdIXoo8P_<_dUOwqbJFrrXvG7-``;3R0-?+C?W(HQ%Nqn>@s(a!$t z*uWlldfVFAFPse#4E~JM$KG*n40eTXi&p!hiR&rL4!F94;Rt)owJDk41y8!xN27_& zq1FUD>bezKUpU5|D4~LAEZ&5k&X+Vt!gnP@n?td1u#-LHcET?g%iYRYDW~t>9Tvf- z9h|eQgY)=%heg_dI>McuTf&Ks^?O0#w4*Z_?_ghZ1`{k(;$nlhlPOAuwjk-01q*uBnZGQl2pL*-7C)d#t^82Uk{@Yiydop7S``b8v_fO34FiluLhReFU?M1}V0|Uw80m*YM2qP2 zs~AJ?-;%$S|!Nspbso@_SsKd@bzb|5;mwiQFFjbGfvlajV(d;2iImAbrvcb34!A)(`?|Y?okn>HGkH42 z(;U*=twXM+x~8V40mq=L*E!%Eatt~q+@1;7WGU_6ei&QiW^CX_>+g9C5uT6oUJE}% z_#(yz1qNga{!mEnGgkcqfd{HAd>LUB4(_w?)dC+77|nS5iIrBp&#wQ9g#!ZrNMI~1 zZf{879Rfct@Ld8Q7WnT3ep=xB3DX}oS!LP(hNvGF^$!a?A@HL%?zi;+i7?uCUt{5a z7I^Se7Jgpfi4_+9rNEPw7XF>U9?|}cz)ZA%Pv9X@??hkJUz4c6NZ`urEPLewd&GD? zP8jnw&}-FSO&I*YBK%)1@JWGh7WkCFTLhjIxZTG0SoU@ad|F^#U{l}+1)dW4dxRb3 z7?suj2*==WxrIlBeop9*iTcWGt@@t|+_c8RuK-*Bag*$gB7CL@&%**O)GsT-i;M7O zMfej%`065DRfKDbu(t@`RD?Gb;Vng2E5aQ`I8uan7vZZx6P6MKoeWEoVVf~5MTYIk zu!Pw4ct4F7%ZJfkya8`D-Wt5C@q%_*nrtoJ{|Q?jrs3-2r#NNiobH-^!SVYpk8mh! z8wzg<%|7hx3_qW3z)xu##F^$RxEVCunHSs)nvZS}4d*65wJ9U+49dbny>)A9@Ot)s z)avPeEYu}D_ny=0`L(On^LtjS=eMp_Z(X+ z?f4u&&{kZHxDNB&%@$!0Oq&xrXzvrpXjT}5NDP-eqAt1&H6EiNLM({)=ERFU(wkFa zMUYn5X9s*D)DuCT2=7E-XNPolFlU8vb^vFGZd@X0Bgw-xD^SZvXcq*l#k{WwHbiy> iJHu`H2n Date: Thu, 18 Aug 2022 13:31:10 +0200 Subject: [PATCH 21/21] Updates py65 Version --- 6502/py65/6502f83.fb | 2 +- 6502/py65/6502f83.fth | 16 ++++++++-------- 6502/py65/vfpy65.bin | Bin 17574 -> 17587 bytes 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/6502/py65/6502f83.fb b/6502/py65/6502f83.fb index fa9a30e..4795ada 100644 --- a/6502/py65/6502f83.fb +++ b/6502/py65/6502f83.fb @@ -1 +1 @@ - ende 123 \ volksFORTH Loadscreen for py65 target cas 15juli2020forth definitions : (C [compile] ( ; IMMEDIATE \ : ) ; IMMEDIATE $1000 CONSTANT BASEADDR \ change target base address here BASEADDR DISPLACE ! TARGET DEFINITIONS BASEADDR HERE! hex &01 &126 +THRU decimal \ ASSEMBLER NONRELOCATE .UNRESOLVED \ if this prints unresolved \ definitions, check code CR .( SAVE-TARGET 6502-FORTH83) \ FORTH PREAMBLE AND ID cas 26jan06 ASSEMBLER NOP 0 JMP HERE 2- >LABEL >COLD NOP 0 JMP HERE 2- >LABEL >RESTART HERE DUP ORIGIN! \ Coldstartvalues and user variables cas 15juli2020\ 0 JMP 0 JSR HERE 2- >LABEL >WAKE END-CODE 0D6 ALLOT \ Bootlabel ," VOLKSFORTH-83 3.8 py65 15july2020 CS" \ ZERO PAGE VARIABLES & NEXT cas 26jan06\ adjust this to match your architecture 20 DUP >LABEL RP 2+ DUP >LABEL UP 2+ DUP >LABEL PUTA 1+ DUP >LABEL SP 2+ DUP >LABEL NEXT DUP 5 + >LABEL IP 13 + >LABEL W W 8 + >LABEL N \ NEXT, MOVED INTO ZERO PAGE 08APR85BP) LABEL BOOTNEXT -1 STA \ -1 IS DUMMY SP IP )Y LDA W 1+ STA -1 LDA W STA \ -1 IS DUMMY IP CLC IP LDA 2 # ADC IP STA CS NOT ?[ LABEL WJMP -1 ) JMP ]? IP 1+ INC WJMP BCS END-CODE \ Bootnext and Endtrace cas 26jan06HERE BOOTNEXT - >LABEL BOOTNEXTLEN CODE END-TRACE ( PATCH NEXT FOR TRACE ) 0A5 # LDA NEXT 0A + STA IP # LDA NEXT 0B + STA 069 # LDA NEXT 0C + STA 02 # LDA NEXT 0D + STA NEXT JMP END-CODE \ ;C: NOOP cas 26jan06 CREATE RECOVER ASSEMBLER PLA W STA PLA W 1+ STA W WDEC 0 JMP END-CODE HERE 2- >LABEL >RECOVER \ manual forward reference for JMP command COMPILER ASSEMBLER ALSO DEFINITIONS H : ;C: 0 T RECOVER JSR END-CODE ] H ; TARGET CODE NOOP NEXT HERE 2- ! END-CODE \ USER VARIABLES cas 26jan06 CONSTANT ORIGIN 8 UALLOT DROP \ FOR MULTITASKER \ Adjust memory values for data stack and return stack here USER S0 $5000 S0 ! USER R0 $5500 R0 ! USER DP USER OFFSET 0 OFFSET ! USER BASE &10 BASE ! USER OUTPUT USER INPUT USER ERRORHANDLER \ POINTER FOR ABORT" -CODE USER VOC-LINK USER UDP \ POINTS TO NEXT FREE ADDR IN USER \ MANIPULATE SYSTEM POINTERS 29JAN85BP) CODE SP@ ( -- ADDR) SP LDA N STA SP 1+ LDA N 1+ STA N # LDX LABEL XPUSH SP 2DEC 1 ,X LDA SP )Y STA 0 ,X LDA 0 # LDX PUTA JMP END-CODE CODE SP! ( ADDR --) SP X) LDA TAX SP )Y LDA SP 1+ STA SP STX 0 # LDX NEXT JMP END-CODE \ UP@ UP! XPULL (XYDROP (DROP cas 26jan06CODE UP@ ( -- ADDR) UP # LDX XPUSH JMP END-CODE CODE UP! ( ADDR --) UP # LDX LABEL XPULL SP )Y LDA 1 ,X STA DEY SP )Y LDA 0 ,X STA LABEL (XYDROP 0 # LDX 1 # LDY LABEL (DROP SP 2INC NEXT JMP END-CODE RESTRICT \ MANIPULATE RETURNSTACK 16FEB85BP/KS) CODE RP@ ( -- ADDR ) RP # LDX XPUSH JMP END-CODE CODE RP! ( ADDR -- ) RP # LDX XPULL JMP END-CODE RESTRICT CODE >R ( 16B -- ) RP 2DEC SP X) LDA RP X) STA SP )Y LDA RP )Y STA (DROP JMP END-CODE RESTRICT \ R> (RDROP (NRDROP cas 26jan06CODE R> ( -- 16B) SP 2DEC RP X) LDA SP X) STA RP )Y LDA SP )Y STA LABEL (RDROP 2 # LDA LABEL (NRDROP CLC RP ADC RP STA CS ?[ RP 1+ INC ]? NEXT JMP END-CODE RESTRICT \ R@ RDROP EXIT ?EXIT 08APR85BP) CODE R@ ( -- 16B) SP 2DEC RP )Y LDA SP )Y STA RP X) LDA PUTA JMP END-CODE CODE RDROP (RDROP HERE 2- ! END-CODE RESTRICT CODE EXIT RP X) LDA IP STA RP )Y LDA IP 1+ STA (RDROP JMP END-CODE \ EXECUTE PERFORM 08APR85BP) CODE ?EXIT ( FLAG -- ) SP X) LDA SP )Y ORA PHP SP 2INC PLP ' EXIT @ BNE NEXT JMP END-CODE CODE EXECUTE ( ADDR --) SP X) LDA W STA SP )Y LDA W 1+ STA SP 2INC W 1- JMP END-CODE : PERFORM ( ADDR -- ) @ EXECUTE ; \ C@ C! CTOGGLE 10JAN85BP) CODE C@ ( ADDR -- 8B) SP X) LDA N STA SP )Y LDA N 1+ STA LABEL (C@ 0 # LDA SP )Y STA N X) LDA PUTA JMP END-CODE CODE C! ( 16B ADDR --) SP X) LDA N STA SP )Y LDA N 1+ STA INY SP )Y LDA N X) STA DEY LABEL (2DROP SP LDA CLC 4 # ADC SP STA CS ?[ SP 1+ INC ]? NEXT JMP END-CODE \ @ ! +! 08APR85BP) er14dez88 : CTOGGLE ( 8B ADDR --) UNDER C@ XOR SWAP C! ; CODE @ ( ADDR -- 16B) SP X) LDA N STA SP )Y LDA N 1+ STA N )Y LDA SP )Y STA N X) LDA PUTA JMP END-CODE CODE ! ( 16B ADDR --) SP X) LDA N STA SP )Y LDA N 1+ STA INY SP )Y LDA N X) STA INY SP )Y LDA 1 # LDY LABEL (! N )Y STA (2DROP JMP END-CODE \ +! DROP cas 26jan06 CODE +! ( N ADDR --) SP X) LDA N STA SP )Y LDA N 1+ STA INY SP )Y LDA CLC N X) ADC N X) STA INY SP )Y LDA 1 # LDY N )Y ADC (! JMP END-CODE CODE DROP ( 16B --) (DROP HERE 2- ! END-CODE \ SWAP cas 26jan06CODE SWAP ( 16B1 16B2 -- 16B2 16B1 ) SP )Y LDA TAX 3 # LDY SP )Y LDA N STA TXA SP )Y STA N LDA 1 # LDY SP )Y STA INY 0 # LDX SP )Y LDA N STA SP X) LDA SP )Y STA DEY N LDA PUTA JMP END-CODE \ DUP ?DUP 08MAY85BP) cas 26jan06 CODE DUP ( 16B -- 16B 16B) SP 2DEC 3 # LDY SP )Y LDA 1 # LDY SP )Y STA INY SP )Y LDA DEY PUTA JMP END-CODE CODE ?DUP ( 16B -- 16B 16B / FALSE) SP X) LDA SP )Y ORA 0= ?[ NEXT JMP ]? ' DUP @ JMP END-CODE \\ ?DUP and DUP in FORTH \ : ?DUP ( 16B -- 16B 16B / FALSE) \ DUP IF DUP THEN ; \ : DUP SP@ @ ; \ OVER ROT 13JUN84KS) cas 26jan06 CODE OVER ( 16B1 16B2 - 16B1 16B3 16B1) SP 2DEC 4 # LDY SP )Y LDA SP X) STA INY SP )Y LDA 1 # LDY SP )Y STA NEXT JMP END-CODE \\ ROT OVER in FORTH \ : ROT >R SWAP R> SWAP ; \ : OVER >R DUP R> SWAP ; \ ROT cas 26jan06CODE ROT ( 16B1 16B2 16B3 -- 16B2 16B3 16B1) 3 # LDY SP )Y LDA N 1+ STA 1 # LDY SP )Y LDA 3 # LDY SP )Y STA 5 # LDY SP )Y LDA N STA N 1+ LDA SP )Y STA 1 # LDY N LDA SP )Y STA INY SP )Y LDA N 1+ STA SP X) LDA SP )Y STA 4 # LDY SP )Y LDA SP X) STA N 1+ LDA SP )Y STA 1 # LDY NEXT JMP END-CODE \ -ROT NIP UNDER PICK ROLL 24DEC83KS) cas 26jan06: -ROT ( 16B1 16B2 16B3 -- 16B3 16B1 16B2) ROT ROT ; : NIP ( 16B1 16B2 -- 16B2) SWAP DROP ; : UNDER ( 16B1 16B2 -- 16B2 16B1 16B2) SWAP OVER ; : PICK ( N -- 16B.N ) 1+ 2* SP@ + @ ; : ROLL ( N --) DUP >R PICK SP@ DUP 2+ R> 1+ 2* CMOVE> DROP ; \\ : -ROLL ( N --) >R DUP SP@ DUP 2+ DUP 2+ SWAP R@ 2* CMOVE R> 1+ 2* + ! ; \ DOUBLE WORD STACK MANIP. 21APR83KS) : 2SWAP ( 32B1 32B2 -- 32B2 32B1) ROT >R ROT R> ; CODE 2DROP ( 32B -- ) (2DROP HERE 2- ! END-CODE : 2DUP ( 32B -- 32B 32B) OVER OVER ; \ : 2DROP ( 32B -- ) DROP DROP ; \ + AND OR XOR 08APR85BP) COMPILER ASSEMBLER ALSO DEFINITIONS H : DYADOP ( OPCODE --) T INY SP X) LDA DUP C, SP C, SP )Y STA DEY SP )Y LDA 3 # LDY C, SP C, SP )Y STA (XYDROP JMP H ; TARGET CODE + ( N1 N2 -- N3) CLC 071 DYADOP END-CODE CODE OR ( 16B1 16B2 -- 16B3) 011 DYADOP END-CODE CODE AND ( 16B1 16B2 -- 16B3) 031 DYADOP END-CODE CODE XOR ( 16B1 16B2 -- 16B3) 051 DYADOP END-CODE \ - NOT NEGATE 24DEC83KS) CODE - ( N1 N2 -- N3) INY SP )Y LDA SEC SP X) SBC SP )Y STA INY SP )Y LDA 1 # LDY SP )Y SBC 3 # LDY SP )Y STA (XYDROP JMP END-CODE CODE NOT ( 16B1 -- 16B2) CLC LABEL (NOT TXA SP X) SBC SP X) STA TXA SP )Y SBC SP )Y STA NEXT JMP END-CODE CODE NEGATE ( N1 -- N2 ) SEC (NOT BCS END-CODE \ : - NEGATE + ; \ DNEGATE SETUP D+ 14JUN84KS) CODE DNEGATE ( D1 -- -D1) INY SEC TXA SP )Y SBC SP )Y STA INY TXA SP )Y SBC SP )Y STA TXA SP X) SBC SP X) STA 1 # LDY TXA SP )Y SBC SP )Y STA NEXT JMP END-CODE LABEL SETUP ( QUAN IN A) .A ASL TAX TAY DEY [[ SP )Y LDA N ,Y STA DEY 0< ?] TXA CLC SP ADC SP STA CS ?[ SP 1+ INC ]? 0 # LDX 1 # LDY RTS END-CODE \ D+ cas 26jan06CODE D+ ( D1 D2 -- D3) 2 # LDA SETUP JSR INY SP )Y LDA CLC N 2+ ADC SP )Y STA INY SP )Y LDA N 3 + ADC SP )Y STA SP X) LDA N ADC SP X) STA 1 # LDY SP )Y LDA N 1+ ADC SP )Y STA NEXT JMP END-CODE \ 1+ 2+ 3+ 1- 2- 08APR85BP) CODE 1+ ( N1 -- N2) 1 # LDA LABEL N+ CLC SP X) ADC CS NOT ?[ PUTA JMP ]? SP X) STA SP )Y LDA 0 # ADC SP )Y STA NEXT JMP END-CODE CODE 2+ ( N1 -- N2) 2 # LDA N+ BNE END-CODE CODE 3+ ( N1 -- N2) 3 # LDA N+ BNE END-CODE | CODE 4+ ( N1 -- N2) 4 # LDA N+ BNE END-CODE | CODE 6+ ( N1 -- N2) 6 # LDA N+ BNE END-CODE \ NUMBER CONSTANTS 24DEC83KS) CODE 1- ( N1 -- N2) SEC LABEL (1- SP X) LDA 1 # SBC CS ?[ PUTA JMP ]? SP X) STA SP )Y LDA 0 # SBC SP )Y STA NEXT JMP END-CODE CODE 2- ( N1 -- N2) CLC (1- BCC END-CODE -1 CONSTANT TRUE 0 CONSTANT FALSE ' TRUE ALIAS -1 ' FALSE ALIAS 0 1 CONSTANT 1 2 CONSTANT 2 3 CONSTANT 3 4 CONSTANT 4 : ON ( ADDR -- ) TRUE SWAP ! ; : OFF ( ADDR -- ) FALSE SWAP ! ; \ WORDS FOR NUMBER LITERALS 24MAY84KS) cs08aug05 CODE CLIT ( -- 8B) SP 2DEC IP X) LDA SP X) STA TXA SP )Y STA IP WINC NEXT JMP END-CODE RESTRICT CODE LIT ( -- 16B) SP 2DEC IP )Y LDA SP )Y STA IP X) LDA SP X) STA LABEL (BUMP IP 2INC NEXT JMP END-CODE RESTRICT : LITERAL ( 16B --) DUP 0FF00 AND IF COMPILE LIT , EXIT THEN COMPILE CLIT C, ; IMMEDIATE RESTRICT \\ : LIT R> DUP 2+ >R @ ; : CLIT R> DUP 1+ >R C@ ; \ COMPARISION CODE WORDS 13JUN84KS) CODE 0< ( N -- FLAG) SP )Y LDA 0< ?[ LABEL PUTTRUE 0FF # LDA 024 C, ]? LABEL PUTFALSE TXA SP )Y STA PUTA JMP END-CODE CODE 0= ( 16B -- FLAG) SP X) LDA SP )Y ORA PUTTRUE BEQ PUTFALSE BNE END-CODE CODE UWITHIN ( U1 [LOW UP[ -- FLAG) 2 # LDA SETUP JSR 1 # LDY SP X) LDA N CMP SP )Y LDA N 1+ SBC CS NOT ?[ ( N>SP) SP X) LDA N 2+ CMP SP )Y LDA N 3 + SBC PUTTRUE BCS ]? PUTFALSE JMP END-CODE \ COMPARISION CODE WORDS 13JUN84KS) CODE < ( N1 N2 -- FLAG) SP X) LDA N STA SP )Y LDA N 1+ STA SP 2INC N 1+ LDA SP )Y EOR ' 0< @ BMI SP X) LDA N CMP SP )Y LDA N 1+ SBC ' 0< @ 2+ JMP END-CODE CODE U< ( U1 U2 -- FLAG) SP X) LDA N STA SP )Y LDA N 1+ STA SP 2INC SP X) LDA N CMP SP )Y LDA N 1+ SBC CS NOT ?[ PUTTRUE JMP ]? PUTFALSE JMP END-CODE \ COMPARISION WORDS 24DEC83KS) | : 0< 8000 AND 0<> ; : > ( N1 N2 -- FLAG) SWAP < ; : 0> ( N -- FLAG) NEGATE 0< ; : 0<> ( N -- FLAG) 0= NOT ; : U> ( U1 U2 -- FLAG) SWAP U< ; : = ( N1 N2 -- FLAG) - 0= ; : D0= ( D -- FLAG) OR 0= ; : D= ( D1 D2 -- FLAG) DNEGATE D+ D0= ; : D< ( D1 D2 -- FLAG) ROT 2DUP - IF > NIP NIP ELSE 2DROP U< THEN ; \ MIN MAX UMAX UMIN EXTEND DABS ABS cas 26jan06 | : MINIMAX ( N1 N2 FLAG -- N3) RDROP IF SWAP THEN DROP ; : MIN ( N1 N2 -- N3) 2DUP > MINIMAX ; -2 ALLOT : MAX ( N1 N2 -- N3) 2DUP < MINIMAX ; -2 ALLOT : UMAX ( U1 U2 -- U3) 2DUP U< MINIMAX ; -2 ALLOT : UMIN ( U1 U2 -- U3) 2DUP U> MINIMAX ; -2 ALLOT : EXTEND ( N -- D) DUP 0< ; : DABS ( D -- UD) EXTEND IF DNEGATE THEN ; : ABS ( N -- U) EXTEND IF NEGATE THEN ; \ LOOP PRIMITIVES 08FEB85BP/KS) | : DODO RDROP R> 2+ DUP >R ROT >R SWAP >R >R ; : (DO ( LIMIT STAR -- ) OVER - DODO ; -2 ALLOT RESTRICT : (?DO ( LIMIT START -- ) OVER - ?DUP IF DODO THEN R> DUP @ + >R DROP ; RESTRICT : BOUNDS ( START COUNT -- LIMIT START ) OVER + SWAP ; CODE ENDLOOP 6 # LDA (NRDROP JMP END-CODE RESTRICT \\ DODO PUTS "INDEX \ LIMIT \ ADR.OF.DO" ON RETURN-STACK \ (LOOP (+LOOP 08APR85BP) CODE (LOOP CLC 1 # LDA RP X) ADC RP X) STA CS ?[ RP )Y LDA 0 # ADC RP )Y STA CS ?[ NEXT JMP ]? ]? LABEL DOLOOP 5 # LDY RP )Y LDA IP 1+ STA DEY RP )Y LDA IP STA 1 # LDY NEXT JMP END-CODE RESTRICT CODE (+LOOP CLC SP X) LDA RP X) ADC RP X) STA SP )Y LDA RP )Y ADC RP )Y STA .A ROR SP )Y EOR PHP SP 2INC PLP DOLOOP BPL NEXT JMP END-CODE RESTRICT \ LOOP INDICES 08APR85BP) CODE I ( -- N) 0 # LDY LABEL LOOPINDEX SP 2DEC CLC RP )Y LDA INY INY RP )Y ADC SP X) STA DEY RP )Y LDA INY INY RP )Y ADC 1 # LDY SP )Y STA NEXT JMP END-CODE RESTRICT CODE J ( -- N) 6 # LDY LOOPINDEX BNE END-CODE RESTRICT \ BRANCHING 24DEC83KS) CODE BRANCH CLC IP LDA IP X) ADC N STA IP 1+ LDA IP )Y ADC IP 1+ STA N LDA IP STA NEXT JMP END-CODE RESTRICT CODE ?BRANCH SP X) LDA SP )Y ORA PHP SP 2INC PLP ' BRANCH @ BEQ (BUMP JMP END-CODE RESTRICT \\ : BRANCH R> DUP @ + >R ; RESTRICT : ?BRANCH 0= R> OVER NOT OVER 2+ AND -ROT DUP @ + AND OR >R ; RESTRICT \ RESOLVE LOOPS AND BRANCHES 03FEB85BP) : >MARK ( -- ADDR) HERE 0 , ; : >RESOLVE ( ADDR --) HERE OVER - SWAP ! ; : MARK 1 ; IMMEDIATE RESTRICT : THEN ABS 1 ?PAIRS >RESOLVE ; IMMEDIATE RESTRICT : ELSE 1 ?PAIRS COMPILE BRANCH >MARK SWAP >RESOLVE -1 ; IMMEDIATE RESTRICT : BEGIN MARK -2 2SWAP ; IMMEDIATE RESTRICT | : (REPTIL RESOLVE REPEAT ; : REPEAT 2 ?PAIRS COMPILE BRANCH (REPTIL ; IMMEDIATE RESTRICT : UNTIL 2 ?PAIRS COMPILE ?BRANCH (REPTIL ; IMMEDIATE RESTRICT \ LOOPS 29JAN85KS/BP) : DO COMPILE (DO >MARK 3 ; IMMEDIATE RESTRICT : ?DO COMPILE (?DO >MARK 3 ; IMMEDIATE RESTRICT : LOOP 3 ?PAIRS COMPILE (LOOP COMPILE ENDLOOP >RESOLVE ; IMMEDIATE RESTRICT : +LOOP 3 ?PAIRS COMPILE (+LOOP COMPILE ENDLOOP >RESOLVE ; IMMEDIATE RESTRICT : LEAVE ENDLOOP R> 2- DUP @ + >R ; RESTRICT \\ RETURNSTACK: CALLADR \ INDEX LIMIT \ ADR OF DO \ UM* BP/KS13.2.85) CODE UM* ( U1 U2 -- UD) SP )Y LDA N STA SP X) LDA N 1+ STA INY N 2 + STX N 3 + STX 010 # LDX [[ N 3 + ASL N 2+ ROL N 1+ ROL N ROL CS ?[ CLC SP )Y LDA N 3 + ADC N 3 + STA INY SP )Y LDA DEY N 2 + ADC N 2 + STA CS ?[ N 1+ INC 0= ?[ N INC ]? ]? ]? DEX 0= ?] N 3 + LDA SP )Y STA INY N 2 + LDA SP )Y STA 1 # LDY N LDA SP )Y STA N 1+ LDA SP X) STA NEXT JMP END-CODE \\ : UM* ( U1 U2 -- UD3) >R 0 0 0 R> 010 0 DO DUP 2/ >R 1 AND IF 2OVER D+ THEN >R >R 2DUP D+ R> R> R> LOOP DROP 2SWAP 2DROP ; \ M* 2* 04JUL84KS) : M* ( N1 N2 -- D) DUP 0< DUP >R IF NEGATE THEN SWAP DUP 0< IF NEGATE R> NOT >R THEN UM* R> IF DNEGATE THEN ; : * ( N N -- PROD) UM* DROP ; CODE 2* ( N1 -- N2) SP X) LDA .A ASL SP X) STA SP )Y LDA .A ROL SP )Y STA NEXT JMP END-CODE | : 2* DUP + ; \ UM/MOD 04JUL84KS) | : DIVOVL TRUE ABORT" DIVISION OVERFLOW" ; CODE UM/MOD ( UD U -- UREM UQUOT) SP X) LDA N 5 + STA SP )Y LDA N 4 + STA SP 2INC SP X) LDA N 1+ STA SP )Y LDA N STA INY SP )Y LDA N 3 + STA INY SP )Y LDA N 2+ STA 011 # LDX CLC [[ N 6 + ROR SEC N 1+ LDA N 5 + SBC TAY N LDA N 4 + SBC CS NOT ?[ N 6 + ROL ]? CS ?[ N STA N 1+ STY ]? \ N 3 + ROL N 2+ ROL N 1+ ROL N ROL DEX 0= ?] 1 # LDY N ROR N 1+ ROR CS ?[ ;C: DIVOVL ; ASSEMBLER ]? N 2+ LDA SP )Y STA INY N 1+ LDA SP )Y STA INY N LDA SP )Y STA 1 # LDY N 3 + LDA PUTA JMP END-CODE \ 2/ M/MOD 24DEC83KS) : M/MOD ( D N -- MOD QUOT) DUP >R ABS OVER 0< IF UNDER + SWAP THEN UM/MOD R@ 0< IF NEGATE OVER IF SWAP R@ + SWAP 1- THEN THEN RDROP ; CODE 2/ ( N1 -- N2) SP )Y LDA .A ASL SP )Y LDA .A ROR SP )Y STA SP X) LDA .A ROR PUTA JMP END-CODE \ /MOD / MOD */MOD */ U/MOD UD/MOD KS) : /MOD ( N1 N2 -- REM QUOT) >R EXTEND R> M/MOD ; : / ( N1 N2 -- QUOT) /MOD NIP ; : MOD ( N1 N2 -- REM) /MOD DROP ; : */MOD ( N1 N2 N3 -- REM QUOT) >R M* R> M/MOD ; : */ ( N1 N2 N3 -- QUOT) */MOD NIP ; : U/MOD ( U1 U2 -- UREM UQUOT) 0 SWAP UM/MOD ; : UD/MOD ( UD1 U2 -- UREM UDQUOT) >R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ; \ CMOVE CMOVE> (CMOVE> BP 08APR85) CODE CMOVE ( FROM TO QUAN --) 3 # LDA SETUP JSR DEY [[ [[ N CPY 0= ?[ N 1+ DEC 0< ?[ 1 # LDY NEXT JMP ]? ]? N 4 + )Y LDA N 2+ )Y STA INY 0= ?] N 5 + INC N 3 + INC ]] END-CODE \ CMOVE> MOVE cas 26jan06CODE CMOVE> ( FROM TO QUAN --) 3 # LDA SETUP JSR CLC N 1+ LDA N 3 + ADC N 3 + STA CLC N 1+ LDA N 5 + ADC N 5 + STA N 1+ INC N LDY CLC CS ?[ LABEL (CMOVE> DEY N 4 + )Y LDA N 2+ )Y STA ]? TYA (CMOVE> BNE N 3 + DEC N 5 + DEC N 1+ DEC (CMOVE> BNE 1 # LDY NEXT JMP END-CODE : MOVE ( FROM TO QUAN --) >R 2DUP U< IF R> CMOVE> EXIT THEN R> CMOVE ; \ PLACE COUNT ERASE 16FEB85BP/KS) : PLACE ( ADDR LEN TO --) OVER >R ROT OVER 1+ R> MOVE C! ; CODE COUNT ( ADDR -- ADDR+1 LEN) SP X) LDA N STA CLC 1 # ADC SP X) STA SP )Y LDA N 1+ STA 0 # ADC SP )Y STA SP 2DEC (C@ JMP END-CODE \ : COUNT ( ADR -- ADR+1 LEN ) DUP 1+ SWAP C@ ; : ERASE ( ADDR QUAN --) 0 FILL ; \ FILL 11JUN85BP) CODE FILL ( ADDR QUAN 8B -- ) 3 # LDA SETUP JSR DEY N LDA N 3 + LDX 0<> ?[ [[ [[ N 4 + )Y STA INY 0= ?] N 5 + INC DEX 0= ?] ]? N 2+ LDX 0<> ?[ [[ N 4 + )Y STA INY DEX 0= ?] ]? 1 # LDY NEXT JMP END-CODE \\ : FILL ( ADDR QUAN 8B --) SWAP ?DUP IF >R OVER C! DUP 1+ R> 1- CMOVE EXIT THEN 2DROP ; \ HERE PAD ALLOT , C, COMPILE 24DEC83KS) : HERE ( -- ADDR) DP @ ; : PAD ( -- ADDR) HERE 042 + ; : ALLOT ( N --) DP +! ; : , ( 16B --) HERE ! 2 ALLOT ; : C, ( 8B --) HERE C! 1 ALLOT ; : COMPILE R> DUP 2+ >R @ , ; RESTRICT \ INPUT STRINGS 24DEC83KS) VARIABLE #TIB 0 #TIB ! VARIABLE >TIB $100 >TIB ! \ 050 ALLOT VARIABLE >IN 0 >IN ! VARIABLE BLK 0 BLK ! VARIABLE SPAN 0 SPAN ! : TIB ( -- ADDR ) >TIB @ ; : QUERY TIB 050 EXPECT SPAN @ #TIB ! >IN OFF BLK OFF ; \ SCAN SKIP /STRING 12OCT84BP) : SCAN ( ADDR0 LEN0 CHAR -- ADDR1 LEN1) >R BEGIN DUP WHILE OVER C@ R@ - WHILE 1- SWAP 1+ SWAP REPEAT RDROP ; : SKIP ( ADDR LEN DEL -- ADDR1 LEN1) >R BEGIN DUP WHILE OVER C@ R@ = WHILE 1- SWAP 1+ SWAP REPEAT RDROP ; : /STRING ( ADDR0 LEN0 +N - ADDR1 LEN1) OVER UMIN ROT OVER + -ROT - ; \ CAPITAL 03APR85BP) (C LABEL (CAPITAL \ FOR COMMODORE ONLY PHA 0DF # AND \ 2ND UPPER TO LOWER ASCII A # CMP CS ?[ ASCII Z 1+ # CMP CC ?[ PLA CLC ASCII A ASCII A - # ADC RTS ]? ]? PLA RTS END-CODE ) LABEL (CAPITAL \ FOR ASCII ONLY ASCII a # CMP CS ?[ ASCII z 1+ # CMP CC ?[ SEC ASCII a ASCII A - # SBC ]? ]? RTS END-CODE CODE CAPITAL ( CHAR -- CHAR' ) SP X) LDA (CAPITAL JSR SP X) STA NEXT JMP END-CODE \ CAPITALIZE 03APR85BP) CODE CAPITALIZE ( STRING -- STRING ) SP X) LDA N STA SP )Y LDA N 1+ STA N X) LDA N 2+ STA DEY [[ N 2+ CPY 0= ?[ 1 # LDY NEXT JMP ]? INY N )Y LDA (CAPITAL JSR N )Y STA ]] END-CODE \\ : CAPITALIZE ( STRING -- STRING ) DUP COUNT BOUNDS ?DO I C@ CAPITAL I C! THEN LOOP ; \\ CAPITAL ( CHAR -- CHAR ) ASCII A ASCII Z 1+ UWITHIN IF I C@ [ ASCII A ASCII A - ] LITERAL - ; \ (WORD 08APR85BP) | CODE (WORD ( CHAR ADR0 LEN0 -- ADR) \ N : LENGTH OF SOURCE \ N+2 : PTR IN SOURCE / NEXT CHAR \ N+4 : STRING START ADRESS \ N+6 : STRING LENGTH N 6 + STX \ 0 =: STRING_LENGTH 3 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] 1 # LDY CLC >IN LDA N 2+ ADC N 2+ STA \ >IN+ADR0 =: N+2 >IN 1+ LDA N 3 + ADC N 3 + STA SEC N LDA >IN SBC N STA \ LEN0->IN =: N N 1+ LDA >IN 1+ SBC N 1+ STA CC ?[ SP X) LDA >IN STA \ STREAM EXHAUSTED SP )Y LDA >IN 1+ STA \ (WORD 08APR85BP) ][ 4 # LDY [[ N LDA N 1+ ORA \ SKIP CHAR'S 0= NOT ?[[ N 2+ X) LDA SP )Y CMP \ WHILE COUNT <>0 0= ?[[ N 2+ WINC N WDEC ]]? N 2+ LDA N 4 + STA \ SAVE STRING_START_ADRESS N 3 + LDA N 5 + STA [[ N 2+ X) LDA SP )Y CMP PHP \ SCAN FOR CHAR N 2+ WINC N WDEC PLP 0= NOT ?[[ N 6 + INC \ COUNT STRING_LENGTH N LDA N 1+ ORA 0= ?] ]? ]? \ FROM COUNT = 0 IN SKIP) SEC 2 # LDY \ ADR_AFTER_STRING - ADR0 =: >IN) N 2+ LDA SP )Y SBC >IN STA INY N 3 + LDA SP )Y SBC >IN 1+ STA \ (WORD 08APR85BP) ]? \ FROM 1ST ][, STREAM WAS EXHAUSTED \ WHEN WORD CALLED) CLC 4 # LDA SP ADC SP STA CS ?[ SP 1+ INC ]? \ 2DROP USER' DP # LDY UP )Y LDA SP X) STA N STA INY UP )Y LDA 1 # LDY SP )Y STA N 1+ STA \ DP @ DEY N 6 + LDA \ STORE COUNT BYTE FIRST [[ N )Y STA N 4 + )Y LDA INY N 6 + DEC 0< ?] 020 # LDA N )Y STA \ ADD A BLANK 1 # LDY NEXT JMP END-CODE \ SOURCE WORD PARSE NAME 08APR85BP) : SOURCE ( -- ADDR LEN) BLK @ ?DUP IF BLOCK B/BLK EXIT THEN TIB #TIB @ ; : WORD ( CHAR -- ADDR) SOURCE (WORD ; : PARSE ( CHAR -- ADDR LEN) >R SOURCE >IN @ /STRING OVER SWAP R> SCAN >R OVER - DUP R> 0<> - >IN +! ; : NAME ( -- ADDR) BL WORD CAPITALIZE EXIT ; \\ : WORD ( CHAR -- ADDR) >R SOURCE OVER SWAP >IN @ /STRING R@ SKIP OVER SWAP R> SCAN >R ROT OVER SWAP - R> 0<> - >IN ! OVER - HERE PLACE BL HERE COUNT + C! HERE ; \ STATE ASCII ," (" " 24DEC83KS) VARIABLE STATE 0 STATE ! : ASCII BL WORD 1+ C@ STATE @ IF [COMPILE] LITERAL THEN ; IMMEDIATE : ," ASCII " PARSE HERE OVER 1+ ALLOT PLACE ; : "LIT R> R> UNDER COUNT + >R >R ; RESTRICT : (" "LIT ; RESTRICT : " COMPILE (" ," ; IMMEDIATE RESTRICT \ ." ( .( \ \\ HEX DECIMAL 08SEP84KS) : (." "LIT COUNT TYPE ; RESTRICT : ." COMPILE (." ," ; IMMEDIATE RESTRICT : ( ASCII ) PARSE 2DROP ; IMMEDIATE : .( ASCII ) PARSE TYPE ; IMMEDIATE : \ >IN @ C/L / 1+ C/L * >IN ! ; IMMEDIATE : \\ B/BLK >IN ! ; IMMEDIATE : \NEEDS NAME FIND NIP IF [COMPILE] \ THEN ; : HEX 010 BASE ! ; : DECIMAL 0A BASE ! ; \ NUMBER CONV.: DIGIT? ACCUMULATE KS) : DIGIT? ( CHAR -- DIGIT TRUE/ FALSE ) ASCII 0 - DUP 9 U> IF [ ASCII A ASCII 9 - 1- ] LITERAL - DUP 9 U> IF [ 2SWAP ( UNSTRUKTURIERT) ] THEN BASE @ OVER U> ?DUP ?EXIT THEN DROP FALSE ; : ACCUMULATE ( +D0 ADR DIGIT - +D1 ADR) SWAP >R SWAP BASE @ UM* DROP ROT BASE @ UM* D+ R> ; : CONVERT ( +D1 ADDR0 -- +D2 ADDR2) 1+ BEGIN COUNT DIGIT? WHILE ACCUMULATE REPEAT 1- ; | : END? ( -- FLAG ) PTR @ 0= ; | : CHAR ( ADDR0 -- ADDR1 CHAR ) COUNT -1 PTR +! ; | : PREVIOUS ( ADDR0 -- ADDR0 CHAR) 1- COUNT ; \ ?NONUM ?NUM FIXBASE? 13FEB85KS) VARIABLE DPL -1 DPL ! | : ?NONUM ( FLAG -- EXIT IF TRUE ) IF RDROP 2DROP DROP RDROP FALSE THEN ; | : ?NUM ( FLAG -- EXIT IF TRUE ) IF RDROP DROP R> IF DNEGATE THEN ROT DROP DPL @ 1+ ?DUP ?EXIT DROP TRUE THEN ; | : FIXBASE? ( CHAR - CHAR FALSE / NEWBASE TRUE ) ASCII & CASE? IF 0A TRUE EXIT THEN ASCII $ CASE? IF 10 TRUE EXIT THEN ASCII H CASE? IF 10 TRUE EXIT THEN ASCII % CASE? IF 2 TRUE EXIT THEN FALSE ; \ 13FEB85KS) | : PUNCTUATION? ( CHAR -- FLAG) ASCII , OVER = SWAP ASCII . = OR ; | : ?DPL DPL @ -1 = ?EXIT 1 DPL +! ; | VARIABLE PTR \ POINTS INTO STRING \ (NUMBER NUMBER 13FEB85KS) : NUMBER? ( STRING - STRING FALSE / N 0< / D 0> ) BASE PUSH DUP COUNT PTR ! DPL ON 0 >R ( +SIGN) 0.0 ROT END? ?NONUM CHAR ASCII - CASE? IF RDROP TRUE >R END? ?NONUM CHAR THEN FIXBASE? IF BASE ! END? ?NONUM CHAR THEN BEGIN DIGIT? 0= ?NONUM BEGIN ACCUMULATE ?DPL END? ?NUM CHAR DIGIT? 0= UNTIL PREVIOUS PUNCTUATION? 0= ?NONUM DPL OFF END? ?NUM CHAR REPEAT ; : NUMBER ( STRING -- D ) NUMBER? ?DUP 0= ABORT" ?" 0< IF EXTEND THEN ; \ HIDE REVEAL IMMEDIATE RESTRICT KS) VARIABLE LAST 0 LAST ! | : LAST? ( -- FALSE / ACF TRUE) LAST @ ?DUP ; : HIDE LAST? IF 2- @ CURRENT @ ! THEN ; : REVEAL LAST? IF 2- CURRENT @ ! THEN ; : RECURSIVE REVEAL ; IMMEDIATE RESTRICT | : FLAG! ( 8B --) LAST? IF UNDER C@ OR OVER C! THEN DROP ; : IMMEDIATE 040 FLAG! ; : RESTRICT 080 FLAG! ; \ CLEARSTACK HALLOT HEAP HEAP? cas 26jan06 CODE CLEARSTACK USER' S0 # LDY UP )Y LDA SP STA INY UP )Y LDA SP 1+ STA 1 # LDY NEXT JMP END-CODE : HALLOT ( QUAN -- ) S0 @ OVER - SWAP SP@ 2+ DUP ROT - DUP S0 ! 2 PICK OVER - MOVE CLEARSTACK S0 ! ; : HEAP ( -- ADDR) S0 @ 6+ ; : HEAP? ( ADDR -- FLAG) HEAP UP@ UWITHIN ; | : HEAPMOVE ( FROM -- FROM) DUP HERE OVER - DUP HALLOT HEAP SWAP CMOVE HEAP OVER - LAST +! REVEAL ; \ DOES> ; 30DEC84KS/BP) LABEL (DODOES> RP 2DEC IP 1+ LDA RP )Y STA IP LDA RP X) STA \ PUT IP ON RP CLC W X) LDA 3 # ADC IP STA TXA W )Y ADC IP 1+ STA \ W@ + 3 -> IP LABEL DOCREATE 2 # LDA CLC W ADC PHA TXA W 1+ ADC PUSH JMP END-CODE | : (;CODE R> LAST @ NAME> ! ; : DOES> COMPILE (;CODE 04C C, COMPILE (DODOES> ; IMMEDIATE RESTRICT \ 6502-ALIGN ?HEAD \ 08SEP84BP) | : 6502-ALIGN/1 ( ADR -- ADR' ) DUP 0FF AND 0FF = - ; | : 6502-ALIGN/2 ( LFA -- LFA ) HERE 0FF AND 0FF = IF DUP DUP 1+ HERE OVER - 1+ CMOVE> \ LFA NOW INVALID 1 LAST +! 1 ALLOT THEN ; VARIABLE ?HEAD 0 ?HEAD ! : | ?HEAD @ ?EXIT -1 ?HEAD ! ; \ WARNING CREATE 30DEC84BP) VARIABLE WARNING 0 WARNING ! | : EXISTS? WARNING @ ?EXIT LAST @ CURRENT @ (FIND NIP IF SPACE LAST @ .NAME ." EXISTS " ?CR THEN ; : CREATE HERE BLK @ , CURRENT @ @ , NAME C@ DUP 1 020 UWITHIN NOT ABORT" INVALID NAME" HERE LAST ! 1+ ALLOT EXISTS? ?HEAD @ IF 1 ?HEAD +! DUP 6502-ALIGN/1 , \ POINTER TO CODE HEAPMOVE 020 FLAG! 6502-ALIGN/1 DP ! ELSE 6502-ALIGN/2 DROP THEN REVEAL 0 , ;CODE DOCREATE JMP END-CODE \ NFA? 30DEC84BP) | CODE NFA? ( VOCABTHREAD CFA -- NFA / FALSE) SP X) LDA N 4 + STA SP )Y LDA N 5 + STA SP 2INC [[ [[ SP X) LDA N 2+ STA SP )Y LDA N 3 + STA N 2+ ORA 0= ?[ PUTFALSE JMP ]? N 2+ )Y LDA SP )Y STA N 1+ STA N 2+ X) LDA SP X) STA N STA N 1+ ORA 0= ?[ NEXT JMP ]? \ N=LINK N 2INC N X) LDA PHA SEC 01F # AND N ADC N STA CS ?[ N 1+ INC ]? PLA 020 # AND 0= NOT ?[ N )Y LDA PHA N X) LDA N STA PLA N 1+ STA ]? N LDA N 4 + CMP 0= ?] \ VOCABTHREAD=0 N 1+ LDA N 5 + CMP 0= ?] \ D.H. LEERES VOCABULARY ' 2+ @ JMP END-CODE \ IN NFA? IST ERLAUBT \ >NAME NAME> >BODY .NAME 03FEB85BP) : >NAME ( CFA -- NFA / FALSE) VOC-LINK BEGIN @ DUP WHILE 2DUP 4 - SWAP NFA? ?DUP IF -ROT 2DROP EXIT THEN REPEAT NIP ; | : (NAME> ( NFA -- CFA) COUNT 01F AND + ; : NAME> ( NFA -- CFA) DUP (NAME> SWAP C@ 020 AND IF @ THEN ; : >BODY ( CFA -- PFA) 2+ ; : .NAME ( NFA --) ?DUP IF DUP HEAP? IF ." |" THEN COUNT 01F AND TYPE ELSE ." ???" THEN SPACE ; \ : ; CONSTANT VARIABLE 09JAN85KS/BP) : : CREATE HIDE CURRENT @ CONTEXT ! ] 0 ;CODE HERE >RECOVER ! \ RESOLVE FWD. REFERENCE RP 2DEC IP LDA RP X) STA IP 1+ LDA RP )Y STA W LDA CLC 2 # ADC IP STA TXA W 1+ ADC IP 1+ STA NEXT JMP END-CODE : ; 0 ?PAIRS COMPILE EXIT [COMPILE] [ REVEAL ; IMMEDIATE RESTRICT : CONSTANT ( 16B --) CREATE , ;CODE SP 2DEC 2 # LDY W )Y LDA SP X) STA INY W )Y LDA 1 # LDY SP )Y STA NEXT JMP END-CODE : VARIABLE CREATE 2 ALLOT ; \ UALLOT USER ALIAS 10JAN85KS/BP) : UALLOT ( QUAN -- OFFSET) DUP UDP @ + 0FF U> ABORT" USERAREA FULL" UDP @ SWAP UDP +! ; : USER CREATE 2 UALLOT C, ;CODE SP 2DEC 2 # LDY W )Y LDA CLC UP ADC SP X) STA TXA INY UP 1+ ADC 1 # LDY SP )Y STA NEXT JMP END-CODE : ALIAS ( CFA --) CREATE LAST @ DUP C@ 020 AND IF -2 ALLOT ELSE 020 FLAG! THEN (NAME> ! ; \ VOC-LINK VP CURRENT CONTEXT ALSO BP) CREATE VP 10 ALLOT VARIABLE CURRENT : CONTEXT ( -- ADR ) VP DUP @ + 2+ ; | : THRU.VOCSTACK ( -- FROM TO ) VP 2+ CONTEXT ; \ "ONLY FORTH ALSO ASSEMBLER" GIVES VP : \ COUNTWORD = 6 \ONLY\FORTH\ASSEMBLER : ALSO VP @ 0A > ERROR" VOCABULARY STACK FULL" CONTEXT @ 2 VP +! CONTEXT ! ; : TOSS -2 VP +! ; \ VOCABULARY FORTH ONLY FORTH-83 KS/BP) : VOCABULARY CREATE 0 , 0 , HERE VOC-LINK @ , VOC-LINK ! DOES> CONTEXT ! ; \ NAME \ CODE \ THREAD \ COLDTHREAD \ VOC-LINK VOCABULARY FORTH VOCABULARY ONLY ] DOES> [ ONLYPATCH ] 0 VP ! CONTEXT ! ALSO ; ' ONLY ! : ONLYFORTH ONLY FORTH ALSO DEFINITIONS ; \ DEFINITIONS ORDER WORDS 13JAN84BP/KS) : DEFINITIONS CONTEXT @ CURRENT ! ; | : .VOC ( ADR -- ) @ 2- >NAME .NAME ; : ORDER THRU.VOCSTACK DO I .VOC -2 +LOOP 2 SPACES CURRENT .VOC ; : WORDS CONTEXT @ BEGIN @ DUP STOP? 0= AND WHILE ?CR DUP 2+ .NAME SPACE REPEAT DROP ; \ (FIND 08APR85BP) CODE (FIND ( STRING THREAD -- STRING FALSE / NAMEFIELD TRUE) 3 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] N 2+ X) LDA 01F # AND N 4 + STA LABEL FINDLOOP 0 # LDY N )Y LDA TAX INY N )Y LDA N 1+ STA N STX N ORA 0= ?[ 1 # LDY 0 # LDX PUTFALSE JMP ]? INY N )Y LDA 01F # AND N 4 + CMP FINDLOOP BNE \ COUNTBYTE MATCH CLC 2 # LDA N ADC N 5 + STA 0 # LDA N 1+ ADC N 6 + STA N 4 + LDY [[ N 2+ )Y LDA N 5 + )Y CMP \ FINDLOOP BNE DEY 0= ?] 3 # LDY N 6 + LDA SP )Y STA DEY N 5 + LDA SP )Y STA DEY 0 # LDX PUTTRUE JMP END-CODE \ FOUND 29JAN85BP) | CODE FOUND ( NFA -- CFA N ) SP X) LDA N STA SP )Y LDA N 1+ STA N X) LDA N 2+ STA 01F # AND SEC N ADC N STA CS ?[ N 1+ INC ]? N 2+ LDA 020 # AND 0= ?[ N LDA SP X) STA N 1+ LDA ][ N X) LDA SP X) STA N )Y LDA ]? SP )Y STA SP 2DEC N 2+ LDA 0< ?[ INY ]? .A ASL 0< NOT ?[ TYA 0FF # EOR TAY INY ]? TYA SP X) STA 0< ?[ 0FF # LDA 24 C, ]? TXA 1 # LDY SP )Y STA NEXT JMP END-CODE \\ | : FOUND ( NFA -- CFA N ) DUP C@ >R (NAME> R@ 020 AND IF @ THEN -1 R@ 080 AND IF 1- THEN R> 040 AND IF NEGATE THEN ; \ FIND ' ['] 13JAN85BP) : FIND ( STRING -- CFA N / STRING FALSE) CONTEXT DUP @ OVER 2- @ = IF 2- THEN BEGIN UNDER @ (FIND IF NIP FOUND EXIT THEN OVER VP 2+ U> WHILE SWAP 2- REPEAT NIP FALSE ; : ' ( -- CFA ) NAME FIND 0= ABORT" HAEH?" ; : [COMPILE] ' , ; IMMEDIATE RESTRICT : ['] ' [COMPILE] LITERAL ; IMMEDIATE RESTRICT : NULLSTRING? ( STRING -- STRING FALSE / TRUE) DUP C@ 0= DUP IF NIP THEN ; \ >INTERPRET 28FEB85BP) LABEL JUMP INY CLC W )Y LDA 2 # ADC IP STA INY W )Y LDA 0 # ADC IP 1+ STA 1 # LDY NEXT JMP END-CODE VARIABLE >INTERPRET JUMP ' >INTERPRET ! \\ MAKE VARIABLE >INTERPRET TO SPECIAL DEFER \ INTERPRET INTERACTIVE 31DEC84KS/BP) cas 26jan06 DEFER NOTFOUND : NO.EXTENSIONS ( STRING -- ) ERROR" WHAT?" ; \ STRING NOT 0 ' NO.EXTENSIONS IS NOTFOUND : INTERPRET >INTERPRET ; -2 ALLOT | : INTERACTIVE ?STACK NAME FIND ?DUP IF 1 AND IF EXECUTE >INTERPRET THEN ABORT" COMPILE ONLY" THEN NULLSTRING? ?EXIT NUMBER? 0= IF NOTFOUND THEN >INTERPRET ; -2 ALLOT ' INTERACTIVE >INTERPRET ! \ COMPILING [ ] 20DEC84BP) | : COMPILING ?STACK NAME FIND ?DUP IF 0> IF EXECUTE >INTERPRET THEN , >INTERPRET THEN NULLSTRING? ?EXIT NUMBER? ?DUP IF 0> IF SWAP [COMPILE] LITERAL THEN [COMPILE] LITERAL ELSE NOTFOUND THEN >INTERPRET ; -2 ALLOT : [ ['] INTERACTIVE IS >INTERPRET STATE OFF ; IMMEDIATE : ] ['] COMPILING IS >INTERPRET STATE ON ; \ PERFOM DEFER IS 03FEB85BP) | : CRASH TRUE ABORT" CRASH" ; : DEFER CREATE ['] CRASH , ;CODE 2 # LDY W )Y LDA PHA INY W )Y LDA W 1+ STA PLA W STA 1 # LDY W 1- JMP END-CODE : (IS R> DUP 2+ >R @ ! ; | : DEF? ( CFA -- ) @ ['] NOTFOUND @ OVER = SWAP ['] >INTERPRET @ = OR NOT ABORT" NOT DEFERRED" ; : IS ( ADR -- ) ' DUP DEF? >BODY STATE @ IF COMPILE (IS , EXIT THEN ! ; IMMEDIATE \ ?STACK 08SEP84KS) cas 15july2020 | : STACKFULL ( -- ) DEPTH 20 > ABORT" TIGHT STACK" REVEAL LAST? IF DUP HEAP? IF NAME> ELSE 4 - THEN (FORGET THEN TRUE ABORT" DICTIONARY FULL" ; CODE ?STACK USER' DP # LDY SEC SP LDA UP )Y SBC N STA INY SP 1+ LDA UP )Y SBC 0= ?[ 1 # LDY ;C: STACKFULL ; ASSEMBLER ]? USER' S0 # LDY UP )Y LDA SP CMP INY UP )Y LDA SP 1+ SBC 1 # LDY CS ?[ NEXT JMP ]? ;C: TRUE ABORT" STACK EMPTY" ; -2 ALLOT \\ : ?STACK SP@ HERE - 100 U< IF STACKFULL THEN SP@ S0 @ U> ABORT" STACK EMPTY" ; \ .STATUS PUSH LOAD 08SEP84KS) DEFER .STATUS ' NOOP IS .STATUS | CREATE PULL 0 ] R> R> ! ; : PUSH ( ADDR -- ) R> SWAP DUP >R @ >R PULL >R >R ; RESTRICT : LOAD ( BLK --) ?DUP 0= ?EXIT BLK PUSH BLK ! >IN PUSH >IN OFF .STATUS INTERPRET ; \ +LOAD THRU +THRU --> RDEPTH DEPTH KS) : +LOAD ( OFFSET --) BLK @ + LOAD ; : THRU ( FROM TO --) 1+ SWAP DO I LOAD LOOP ; : +THRU ( OFF0 OFF1 --) 1+ SWAP DO I +LOAD LOOP ; : --> 1 BLK +! >IN OFF .STATUS ; IMMEDIATE : RDEPTH ( -- +N) R0 @ RP@ 2+ - 2/ ; : DEPTH ( -- +N) SP@ S0 @ SWAP - 2/ ; \ QUIT (QUIT ABORT 07JUN85BP) | : PROMPT STATE @ IF ." COMPILING" EXIT THEN ." OK" ; : (QUIT BEGIN .STATUS CR QUERY INTERPRET PROMPT REPEAT ; -2 ALLOT DEFER 'QUIT ' (QUIT IS 'QUIT : QUIT R0 @ RP! [COMPILE] [ 'QUIT ; -2 ALLOT : STANDARDI/O [ OUTPUT ] LITERAL OUTPUT 4 CMOVE ; DEFER 'ABORT ' NOOP IS 'ABORT : ABORT CLEARSTACK END-TRACE 'ABORT STANDARDI/O QUIT ; -2 ALLOT \ (ERROR ABORT" ERROR" 20MAR85BP) VARIABLE SCR 1 SCR ! VARIABLE R# 0 R# ! : (ERROR ( STRING -- ) STANDARDI/O SPACE HERE .NAME COUNT TYPE SPACE ?CR BLK @ ?DUP IF SCR ! >IN @ R# ! THEN QUIT ; -2 ALLOT ' (ERROR ERRORHANDLER ! : (ABORT" "LIT SWAP IF >R CLEARSTACK R> ERRORHANDLER PERFORM EXIT THEN DROP ; RESTRICT \ | : (ERR" "LIT SWAP IF ERRORHANDLER PERFORM EXIT THEN DROP ; RESTRICT : ABORT" COMPILE (ABORT" ," ; IMMEDIATE RESTRICT : ERROR" COMPILE (ERR" ," ; IMMEDIATE RESTRICT \ -TRAILING 08APR85BP) 020 CONSTANT BL CODE -TRAILING ( ADDR N1 -- ADR N2 ) TYA SETUP JSR SP X) LDA N 2+ STA CLC SP )Y LDA N 1+ ADC N 3 + STA N LDY CLC CS ?[ LABEL (-TRAIL DEY N 2+ )Y LDA BL # CMP 0<> ?[ INY 0= ?[ N 1+ INC ]? TYA PHA N 1+ LDA PUSH JMP ]? ]? TYA (-TRAIL BNE N 3 + DEC N 1 + DEC (-TRAIL BPL TYA PUSH0A JMP END-CODE \ SPACE SPACES 29JAN85KS/BP) : SPACE BL EMIT ; : SPACES ( U --) 0 ?DO SPACE LOOP ; \\ : -TRAILING ( ADDR N1 -- ADDR N2) 2DUP BOUNDS ?DO 2DUP + 1- C@ BL - IF LEAVE THEN 1- LOOP ; \ HOLD <# #> SIGN # #S 24DEC83KS) | : HLD ( -- ADDR) PAD 2- ; : HOLD ( CHAR -- ) -1 HLD +! HLD @ C! ; : <# HLD HLD ! ; : #> ( 32B -- ADDR +N ) 2DROP HLD @ HLD OVER - ; : SIGN ( N -- ) 0< IF ASCII - HOLD THEN ; : # ( +D1 -- +D2) BASE @ UD/MOD ROT 09 OVER < IF [ ASCII A ASCII 9 - 1- ] LITERAL + THEN ASCII 0 + HOLD ; : #S ( +D -- 0 0 ) BEGIN # 2DUP D0= UNTIL ; \ PRINT NUMBERS 24DEC83KS) : D.R -ROT UNDER DABS <# #S ROT SIGN #> ROT OVER MAX OVER - SPACES TYPE ; : .R SWAP EXTEND ROT D.R ; : U.R 0 SWAP D.R ; : D. 0 D.R SPACE ; : . EXTEND D. ; : U. 0 D. ; \ .S LIST C/L L/S 24DEC83KS) : .S SP@ S0 @ OVER - 020 UMIN BOUNDS ?DO I @ U. 2 +LOOP ; 40 CONSTANT C/L \ SCREEN LINE LENGTH 10 CONSTANT L/S \ LINES PER SCREEN : LIST ( BLK --) SCR ! ." SCR " SCR @ DUP U. ." DR " DRV? . L/S 0 DO CR I 2 .R SPACE SCR @ BLOCK I C/L * + C/L -TRAILING TYPE LOOP CR ; \ MULTITASKER PRIMITIVES BP03NOV85) CODE PAUSE NEXT HERE 2- ! END-CODE : LOCK ( ADDR --) DUP @ UP@ = IF DROP EXIT THEN BEGIN DUP @ WHILE PAUSE REPEAT UP@ SWAP ! ; : UNLOCK ( ADDR --) DUP LOCK OFF ; LABEL WAKE WAKE >WAKE ! PLA SEC 5 # SBC UP STA PLA 0 # SBC UP 1+ STA 04C # LDA UP X) STA 6 # LDY UP )Y LDA SP STA INY UP )Y LDA SP 1+ STA 1 # LDY SP X) LDA RP STA SP )Y LDA RP 1+ STA SP 2INC IP # LDX XPULL JMP END-CODE \ BUFFER MECHANISM 15DEC83KS) cas 26jan06 USER FILE 0 FILE ! \ ADR OF FILE CONTROL BLOCK VARIABLE PREV 0 PREV ! \ LISTHEAD | VARIABLE BUFFERS 0 BUFFERS ! \ SEMAPHOR 0408 CONSTANT B/BUF \ size of buffer \\ structure of buffer (same for all volksFORTH ) cas 26jan06 0 : LINK 2 : FILE 6 : BLOCKNR 8 : STATUSFLAGS 0A : DATA .. 1 KB .. STATUSFLAG BITS: 15 1 -> UPDATED FILE = -1 EMPTY BUFFER = 0 NO FCB , DIRECT ACCESS = ELSE ADR OF FCB ( SYSTEM DEPENDENT ) \ SEARCH FOR BLOCKS IN MEMORY 11JUN85BP) LABEL THISBUFFER? 2 # LDY [[ N 4 + )Y LDA N 2- ,Y CMP 0= ?[[ INY 6 # CPY 0= ?] ]? RTS \ ZERO IF THIS BUFFER ) | CODE (CORE? ( BLK FILE -- ADDR / BLK FILE ) \ N-AREA : 0 BLK 2 FILE 4 BUFFER \ 6 PREDECESSOR 3 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] USER' OFFSET # LDY CLC UP )Y LDA N 2+ ADC N 2+ STA INY UP )Y LDA N 3 + ADC N 3 + STA PREV LDA N 4 + STA PREV 1+ LDA N 5 + STA THISBUFFER? JSR 0= ?[ \ " 11JUN85BP) LABEL BLOCKFOUND SP 2INC 1 # LDY 8 # LDA CLC N 4 + ADC SP X) STA N 5 + LDA 0 # ADC SP )Y STA ' EXIT @ JMP ]? [[ N 4 + LDA N 6 + STA N 5 + LDA N 7 + STA N 6 + X) LDA N 4 + STA 1 # LDY N 6 + )Y LDA N 5 + STA N 4 + ORA 0= ?[ ( LIST EMPTY ) NEXT JMP ]? THISBUFFER? JSR 0= ?] \ FOUND, RELINK N 4 + X) LDA N 6 + X) STA 1 # LDY N 4 + )Y LDA N 6 + )Y STA PREV LDA N 4 + X) STA PREV 1+ LDA N 4 + )Y STA N 4 + LDA PREV STA N 5 + LDA PREV 1+ STA BLOCKFOUND JMP END-CODE \\ (CORE? 23SEP85BP | : this? ( blk file bufadr -- flag ) DUP 4+ @ SWAP 2+ @ D= ; | : (CORE? ( BLK FILE -- DATAADDR / BLK FILE ) BEGIN OVER OFFSET @ + OVER PREV @ THIS? IF RDROP 2DROP PREV @ 8 + EXIT THEN 2DUP >R OFFSET @ + >R PREV @ BEGIN DUP @ ?DUP 0= IF RDROP RDROP DROP EXIT THEN DUP R> R> 2DUP >R >R ROT THIS? 0= WHILE NIP REPEAT DUP @ ROT ! PREV @ OVER ! PREV ! RDROP RDROP REPEAT ; -2 ALLOT \ (DISKERR 11JUN85BP) : (DISKERR ." ERROR ! R TO RETRY " KEY DUP ASCII R = SWAP ASCII R = OR NOT ABORT" ABORTED" ; DEFER DISKERR ' (DISKERR IS DISKERR DEFER R/W \ BACKUP EMPTYBUF READBLK 11JUN85BP) | : BACKUP ( BUFADDR --) DUP 6+ @ 0< IF 2+ DUP @ 1+ \ BUFFER EMPTY IF FILE = -1 IF INPUT PUSH OUTPUT PUSH STANDARDI/O BEGIN DUP 6+ OVER 2+ @ 2 PICK @ 0 R/W WHILE ." WRITE " DISKERR REPEAT THEN 080 OVER 4+ 1+ CTOGGLE THEN DROP ; | : EMPTYBUF ( BUFADDR --) 2+ DUP ON 4+ OFF ; | : READBLK ( BLK FILE ADDR -- BLK FILE ADDR) DUP EMPTYBUF INPUT PUSH OUTPUT PUSH STANDARDI/O >R BEGIN OVER OFFSET @ + OVER R@ 8 + -ROT 1 R/W WHILE ." READ " DISKERR REPEAT R> ; \ TAKE MARK UPDATES? FULL? CORE? BP) | : TAKE ( -- BUFADDR) PREV BEGIN DUP @ WHILE @ DUP 2+ @ -1 = UNTIL BUFFERS LOCK DUP BACKUP ; | : MARK ( BLK FILE BUFADDR -- BLK FILE ) 2+ >R 2DUP R@ ! OFFSET @ + R@ 2+ ! R> 4+ OFF BUFFERS UNLOCK ; | : UPDATES? ( -- BUFADDR / FLAG) PREV BEGIN @ DUP WHILE DUP 6+ @ 0< UNTIL ; | : FULL? ( -- FLAG) PREV BEGIN @ DUP @ 0= UNTIL 6+ @ 0< ; : CORE? ( BLK FILE -- ADDR /FALSE) (CORE? 2DROP FALSE ; \ BLOCK & BUFFER MANIPULATION 11JUN85BP) : (BUFFER ( BLK FILE -- ADDR) BEGIN (CORE? TAKE MARK REPEAT ; -2 ALLOT : (BLOCK ( BLK FILE -- ADDR) BEGIN (CORE? TAKE READBLK MARK REPEAT ; -2 ALLOT | CODE FILE@ ( -- N ) USER' FILE # LDY UP )Y LDA PHA INY UP )Y LDA PUSH JMP END-CODE : BUFFER ( BLK -- ADDR ) FILE@ (BUFFER ; : BLOCK ( BLK -- ADDR ) FILE@ (BLOCK ; \ BLOCK & BUFFER MANIPULATION 09SEP84KS) : UPDATE 080 PREV @ 6+ 1+ C! ; : SAVE-BUFFERS BUFFERS LOCK BEGIN UPDATES? ?DUP WHILE BACKUP REPEAT BUFFERS UNLOCK ; : EMPTY-BUFFERS BUFFERS LOCK PREV BEGIN @ ?DUP WHILE DUP EMPTYBUF REPEAT BUFFERS UNLOCK ; : FLUSH SAVE-BUFFERS EMPTY-BUFFERS ; \ MOVING BLOCKS 15DEC83KS) cas 26jan06| : (COPY ( FROM TO --) DUP FILE@ CORE? IF PREV @ EMPTYBUF THEN FULL? IF SAVE-BUFFERS THEN OFFSET @ + SWAP BLOCK 2- 2- ! UPDATE ; | : BLKMOVE ( FROM TO QUAN --) SAVE-BUFFERS >R OVER R@ + OVER U> >R 2DUP U< R> AND IF R@ R@ D+ R> 0 ?DO -1 -2 D+ 2DUP (COPY LOOP ELSE R> 0 ?DO 2DUP (COPY 1 1 D+ LOOP THEN SAVE-BUFFERS 2DROP ; : COPY ( FROM TO --) 1 BLKMOVE ; : CONVEY ( [BLK1 BLK2] [TO.BLK --) SWAP 1+ 2 PICK - DUP 0> NOT ABORT" NO!!" BLKMOVE ; \ ALLOCATING BUFFERS 23SEP83KS) 12jan13py F000 CONSTANT LIMIT VARIABLE FIRST : ALLOTBUFFER ( -- ) FIRST @ R0 @ - B/BUF 2+ U< ?EXIT B/BUF NEGATE FIRST +! FIRST @ DUP EMPTYBUF PREV @ OVER ! PREV ! ; : FREEBUFFER ( -- ) FIRST @ LIMIT B/BUF - U< IF SAVE-BUFFERS BEGIN DUP @ FIRST @ - WHILE @ REPEAT FIRST @ @ SWAP ! B/BUF FIRST +! THEN ; : ALL-BUFFERS BEGIN FIRST @ ALLOTBUFFER FIRST @ = UNTIL ; \ ENDPOINTS OF FORGET 04JAN85BP/KS) | : \? ( NFA -- FLAG ) C@ 020 AND ; | : FORGET? ( ADR NFA -- FLAG ) \ CODE IN HEAP OR ABOVE ADR ? NAME> UNDER 1+ U< SWAP HEAP? OR ; | : ENDPOINTS ( ADDR -- ADDR SYMB) HEAP VOC-LINK @ >R BEGIN R> @ ?DUP \ THROUGH ALL VOCABS WHILE DUP >R 4 - >R \ LINK ON RETURNST. BEGIN R> @ >R OVER 1- DUP R@ U< \ UNTIL LINK OR SWAP R@ 2+ NAME> U< AND \ CODE UNDER ADR WHILE R@ HEAP? [ 2DUP ] UNTIL \ SEARCH FOR A NAME IN HEAP R@ 2+ \? IF OVER R@ 2+ FORGET? IF R@ 2+ (NAME> 2+ UMAX THEN \ THEN UPDATE SYMB THEN REPEAT RDROP REPEAT ; \ REMOVE 23JUL85WE | CODE REMOVE ( DIC SYMB THR - DIC SYMB) 5 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] USER' S0 # LDY CLC UP )Y LDA 6 # ADC N 6 + STA INY UP )Y LDA 0 # ADC N 7 + STA 1 # LDY [[ N X) LDA N 8 + STA N )Y LDA N 9 + STA N 8 + ORA 0<> ?[[ N 8 + LDA N 6 + CMP N 9 + LDA N 7 + SBC CS ?[ N 8 + LDA N 2 + CMP N 9 + LDA N 3 + SBC ][ N 4 + LDA N 8 + CMP N 5 + LDA N 9 + SBC ]? CC ?[ N 8 + X) LDA N X) STA N 8 + )Y LDA N )Y STA ][ N 8 + LDA N STA N 9 + LDA N 1+ STA ]? ]]? (DROP JMP END-CODE \ REMOVE- FORGET-WORDS 29APR85BP) | : REMOVE-WORDS ( DIC SYMB -- DIC SYMB) VOC-LINK BEGIN @ ?DUP WHILE DUP >R 4 - REMOVE R> REPEAT ; | : REMOVE-TASKS ( DIC --) UP@ BEGIN 1+ DUP @ UP@ - WHILE 2DUP @ SWAP HERE UWITHIN IF DUP @ 1+ @ OVER ! 1- ELSE @ THEN REPEAT 2DROP ; | : REMOVE-VOCS ( DIC SYMB -- DIC SYMB) VOC-LINK REMOVE THRU.VOCSTACK DO 2DUP I @ -ROT UWITHIN IF [ ' FORTH 2+ ] LITERAL I ! THEN -2 +LOOP 2DUP CURRENT @ -ROT UWITHIN IF [ ' FORTH 2+ ] LITERAL CURRENT ! THEN ; \ FORGET-WORDS cas 26jan06 | : FORGET-WORDS ( DIC SYMB --) OVER REMOVE-TASKS REMOVE-VOCS REMOVE-WORDS HEAP SWAP - HALLOT DP ! 0 LAST ! ; \ DELETING WORDS FROM DICT. 13JAN83KS) : CLEAR HERE DUP UP@ FORGET-WORDS DP ! ; : (FORGET ( ADR --) DUP HEAP? ABORT" IS SYMBOL" ENDPOINTS FORGET-WORDS ; : FORGET ' DUP [ DP ] LITERAL @ U< ABORT" PROTECTED" >NAME DUP HEAP? IF NAME> ELSE 2- 2- THEN (FORGET ; : EMPTY [ DP ] LITERAL @ UP@ FORGET-WORDS [ UDP ] LITERAL @ UDP ! ; \ SAVE BYE STOP? ?CR 20OCT84KS/BP) : SAVE HERE UP@ FORGET-WORDS VOC-LINK @ BEGIN DUP 2- 2- @ OVER 2- ! @ ?DUP 0= UNTIL UP@ ORIGIN 0100 CMOVE ; : BYE FLUSH EMPTY (BYE ; | : END? KEY #CR (C 3 ) = IF TRUE RDROP THEN ; : STOP? ( -- FLAG) KEY? IF END? END? THEN FALSE ; : ?CR COL C/L 0A - U> IF CR THEN ; \ IN/OUTPUT STRUCTURE 02MAR85BP) | : OUT: CREATE DUP C, 2+ DOES> C@ OUTPUT @ + PERFORM ; : OUTPUT: CREATE ] DOES> OUTPUT ! ; 0 OUT: EMIT OUT: CR OUT: TYPE OUT: DEL OUT: PAGE OUT: AT OUT: AT? DROP : ROW ( -- ROW) AT? DROP ; : COL ( -- COL) AT? NIP ; | : IN: CREATE DUP C, 2+ DOES> C@ INPUT @ + PERFORM ; : INPUT: CREATE ] DOES> INPUT ! ; 0 IN: KEY IN: KEY? IN: DECODE IN: EXPECT DROP \ ALIAS ONLY DEFINITIONEN 29JAN85BP) ONLY DEFINITIONS FORTH : SEAL 0 ['] ONLY >BODY ! ; \ KILL ALL WORDS IN ONLY) ' ONLY ALIAS ONLY ' FORTH ALIAS FORTH ' WORDS ALIAS WORDS ' ALSO ALIAS ALSO ' DEFINITIONS ALIAS DEFINITIONS HOST TARGET \ 'COLD 07JUN85BP) cas 15juli2020| : INIT-VOCABULARYS VOC-LINK @ BEGIN DUP 2- @ OVER 4 - ! @ ?DUP 0= UNTIL ; | : INIT-BUFFERS 0 PREV ! LIMIT FIRST ! ALL-BUFFERS ; DEFER 'COLD ' NOOP IS 'COLD | : (COLD INIT-VOCABULARYS INIT-BUFFERS PAGE 'COLD ONLYFORTH ." volksFORTH-83 3.8 py65 202007" CR RESTART ; -2 ALLOT DEFER 'RESTART ' NOOP IS 'RESTART | : (RESTART ['] (QUIT IS 'QUIT DRVINIT 'RESTART [ ERRORHANDLER ] LITERAL @ ERRORHANDLER ! ['] NOOP IS 'ABORT ABORT ; -2 ALLOT \ COLD BOOTSYSTEM RESTART 09JUL85WE) CODE COLD HERE >COLD ! ' (COLD >BODY 100 U/MOD # LDA PHA # LDA PHA LABEL BOOTSYSTEM CLI 0 # LDY CLC S0 LDA 6 # ADC N STA S0 1+ LDA 0 # ADC N 1+ STA [[ ORIGIN ,Y LDA N )Y STA INY 0= ?] LABEL WARMBOOT BOOTNEXTLEN 1- # LDY [[ BOOTNEXT ,Y LDA PUTA ,Y STA DEY 0< ?] CLC S0 LDA 6 # ADC UP STA S0 1+ LDA 0 # ADC UP 1+ STA USER' S0 # LDY UP )Y LDA SP STA INY UP )Y LDA SP 1+ STA USER' R0 # LDY UP )Y LDA RP STA INY UP )Y LDA RP 1+ STA 0 # LDX 1 # LDY TXA RP X) STA RP )Y STA PLA IP STA PLA IP 1+ STA LABEL XYNEXT 0 # LDX 1 # LDY NEXT JMP END-CODE \ ( RESTART PARAM.-PASSING TO FORTH BP) CODE RESTART HERE >RESTART ! ' (RESTART >BODY 100 U/MOD # LDA PHA # LDA PHA WARMBOOT JMP END-CODE \ CODE FOR PARAMETER-PASSING TO FORTH cas 26jan06 \ Include system dependent Input / Output code \ (Keyboard and Screen) include systemio.fb HOST ' TRANSIENT 8 + @ TRANSIENT FORTH CONTEXT @ 6 + ! TARGET FORTH ALSO DEFINITIONS : FORTH-83 ; \ LAST WORD IN DICTIONARY \ SYSTEM DEPENDENT CONSTANTS BP/KS) VOCABULARY ASSEMBLER ASSEMBLER DEFINITIONS TRANSIENT ASSEMBLER PUSHA CONSTANT PUSHA \ PUT A SIGN-EXTENDED ON STACK PUSH0A CONSTANT PUSH0A \ PUT A ON STACK PUSH CONSTANT PUSH \ MSB IN A AND LSB ON JSR-STACK RP CONSTANT RP UP CONSTANT UP SP CONSTANT SP IP CONSTANT IP N CONSTANT N PUTA CONSTANT PUTA W CONSTANT W SETUP CONSTANT SETUP \ NEXT CONSTANT NEXT XYNEXT CONSTANT XYNEXT (2DROP CONSTANT POPTWO (DROP CONSTANT POP \ SYSTEM PATCHUP 05JAN85BP) cas 26jan06 FORTH DEFINITIONS \ change memory layout for stacks and buffers here 6000 ' LIMIT >BODY ! $5800 S0 ! $5B00 R0 ! S0 @ DUP S0 2- ! 6 + S0 7 - ! HERE DP ! HOST TUDP @ TARGET UDP ! HOST TVOC-LINK @ TARGET VOC-LINK ! HOST MOVE-THREADS \ No newline at end of file + ende 123 \ volksFORTH Loadscreen for py65 target cas 02aug2020forth definitions : (C [compile] ( ; IMMEDIATE \ : ) ; IMMEDIATE $1000 CONSTANT BASEADDR \ change target base address here BASEADDR DISPLACE ! TARGET DEFINITIONS BASEADDR HERE! hex &01 &126 +THRU decimal \ ASSEMBLER NONRELOCATE .UNRESOLVED \ if this prints unresolved \ definitions, check code CR .( SAVE-TARGET 6502-FORTH83) \ FORTH PREAMBLE AND ID cas 26jan06 ASSEMBLER NOP 0 JMP HERE 2- >LABEL >COLD NOP 0 JMP HERE 2- >LABEL >RESTART HERE DUP ORIGIN! \ Coldstartvalues and user variables cas 02aug2020\ 0 JMP 0 JSR HERE 2- >LABEL >WAKE END-CODE 0D6 ALLOT \ Bootlabel ," VolksForth-83 3.8.1 py65 02aug2020 CS" \ ZERO PAGE VARIABLES & NEXT cas 26jan06\ adjust this to match your architecture 20 DUP >LABEL RP 2+ DUP >LABEL UP 2+ DUP >LABEL PUTA 1+ DUP >LABEL SP 2+ DUP >LABEL NEXT DUP 5 + >LABEL IP 13 + >LABEL W W 8 + >LABEL N \ NEXT, MOVED INTO ZERO PAGE 08APR85BP) LABEL BOOTNEXT -1 STA \ -1 IS DUMMY SP IP )Y LDA W 1+ STA -1 LDA W STA \ -1 IS DUMMY IP CLC IP LDA 2 # ADC IP STA CS NOT ?[ LABEL WJMP -1 ) JMP ]? IP 1+ INC WJMP BCS END-CODE \ Bootnext and Endtrace cas 26jan06HERE BOOTNEXT - >LABEL BOOTNEXTLEN CODE END-TRACE ( PATCH NEXT FOR TRACE ) 0A5 # LDA NEXT 0A + STA IP # LDA NEXT 0B + STA 069 # LDA NEXT 0C + STA 02 # LDA NEXT 0D + STA NEXT JMP END-CODE \ ;C: NOOP cas 26jan06 CREATE RECOVER ASSEMBLER PLA W STA PLA W 1+ STA W WDEC 0 JMP END-CODE HERE 2- >LABEL >RECOVER \ manual forward reference for JMP command COMPILER ASSEMBLER ALSO DEFINITIONS H : ;C: 0 T RECOVER JSR END-CODE ] H ; TARGET CODE NOOP NEXT HERE 2- ! END-CODE \ USER VARIABLES cas 26jan06 CONSTANT ORIGIN 8 UALLOT DROP \ FOR MULTITASKER \ Adjust memory values for data stack and return stack here USER S0 $5000 S0 ! USER R0 $5500 R0 ! USER DP USER OFFSET 0 OFFSET ! USER BASE &10 BASE ! USER OUTPUT USER INPUT USER ERRORHANDLER \ POINTER FOR ABORT" -CODE USER VOC-LINK USER UDP \ POINTS TO NEXT FREE ADDR IN USER \ MANIPULATE SYSTEM POINTERS 29JAN85BP) cas 02aug2020 CODE SP@ ( -- ADDR) SP LDA N STA SP 1+ LDA N 1+ STA N # LDX LABEL XPUSH SP 2DEC 1 ,X LDA SP )Y STA 0 ,X LDA 0 # LDX PUTA JMP END-CODE CODE SP! ( ADDR --) SP X) LDA TAX SP )Y LDA SP 1+ STA SP STX 0 # LDX NEXT JMP END-CODE \ UP@ UP! XPULL (XYDROP (DROP cas 26jan06CODE UP@ ( -- ADDR) UP # LDX XPUSH JMP END-CODE CODE UP! ( ADDR --) UP # LDX LABEL XPULL SP )Y LDA 1 ,X STA DEY SP )Y LDA 0 ,X STA LABEL (XYDROP 0 # LDX 1 # LDY LABEL (DROP SP 2INC NEXT JMP END-CODE RESTRICT \ MANIPULATE RETURNSTACK 16FEB85BP/KS) CODE RP@ ( -- ADDR ) RP # LDX XPUSH JMP END-CODE CODE RP! ( ADDR -- ) RP # LDX XPULL JMP END-CODE RESTRICT CODE >R ( 16B -- ) RP 2DEC SP X) LDA RP X) STA SP )Y LDA RP )Y STA (DROP JMP END-CODE RESTRICT \ R> (RDROP (NRDROP cas 26jan06CODE R> ( -- 16B) SP 2DEC RP X) LDA SP X) STA RP )Y LDA SP )Y STA LABEL (RDROP 2 # LDA LABEL (NRDROP CLC RP ADC RP STA CS ?[ RP 1+ INC ]? NEXT JMP END-CODE RESTRICT \ R@ RDROP EXIT ?EXIT 08APR85BP) CODE R@ ( -- 16B) SP 2DEC RP )Y LDA SP )Y STA RP X) LDA PUTA JMP END-CODE CODE RDROP (RDROP HERE 2- ! END-CODE RESTRICT CODE EXIT RP X) LDA IP STA RP )Y LDA IP 1+ STA (RDROP JMP END-CODE \ EXECUTE PERFORM 08APR85BP) CODE ?EXIT ( FLAG -- ) SP X) LDA SP )Y ORA PHP SP 2INC PLP ' EXIT @ BNE NEXT JMP END-CODE CODE EXECUTE ( ADDR --) SP X) LDA W STA SP )Y LDA W 1+ STA SP 2INC W 1- JMP END-CODE : PERFORM ( ADDR -- ) @ EXECUTE ; \ C@ C! CTOGGLE 10JAN85BP) CODE C@ ( ADDR -- 8B) SP X) LDA N STA SP )Y LDA N 1+ STA LABEL (C@ 0 # LDA SP )Y STA N X) LDA PUTA JMP END-CODE CODE C! ( 16B ADDR --) SP X) LDA N STA SP )Y LDA N 1+ STA INY SP )Y LDA N X) STA DEY LABEL (2DROP SP LDA CLC 4 # ADC SP STA CS ?[ SP 1+ INC ]? NEXT JMP END-CODE \ @ ! +! 08APR85BP) er14dez88 : CTOGGLE ( 8B ADDR --) UNDER C@ XOR SWAP C! ; CODE @ ( ADDR -- 16B) SP X) LDA N STA SP )Y LDA N 1+ STA N )Y LDA SP )Y STA N X) LDA PUTA JMP END-CODE CODE ! ( 16B ADDR --) SP X) LDA N STA SP )Y LDA N 1+ STA INY SP )Y LDA N X) STA INY SP )Y LDA 1 # LDY LABEL (! N )Y STA (2DROP JMP END-CODE \ +! DROP cas 26jan06 CODE +! ( N ADDR --) SP X) LDA N STA SP )Y LDA N 1+ STA INY SP )Y LDA CLC N X) ADC N X) STA INY SP )Y LDA 1 # LDY N )Y ADC (! JMP END-CODE CODE DROP ( 16B --) (DROP HERE 2- ! END-CODE \ SWAP cas 26jan06CODE SWAP ( 16B1 16B2 -- 16B2 16B1 ) SP )Y LDA TAX 3 # LDY SP )Y LDA N STA TXA SP )Y STA N LDA 1 # LDY SP )Y STA INY 0 # LDX SP )Y LDA N STA SP X) LDA SP )Y STA DEY N LDA PUTA JMP END-CODE \ DUP ?DUP 08MAY85BP) cas 26jan06 CODE DUP ( 16B -- 16B 16B) SP 2DEC 3 # LDY SP )Y LDA 1 # LDY SP )Y STA INY SP )Y LDA DEY PUTA JMP END-CODE CODE ?DUP ( 16B -- 16B 16B / FALSE) SP X) LDA SP )Y ORA 0= ?[ NEXT JMP ]? ' DUP @ JMP END-CODE \\ ?DUP and DUP in FORTH \ : ?DUP ( 16B -- 16B 16B / FALSE) \ DUP IF DUP THEN ; \ : DUP SP@ @ ; \ OVER ROT 13JUN84KS) cas 26jan06 CODE OVER ( 16B1 16B2 - 16B1 16B3 16B1) SP 2DEC 4 # LDY SP )Y LDA SP X) STA INY SP )Y LDA 1 # LDY SP )Y STA NEXT JMP END-CODE \\ ROT OVER in FORTH \ : ROT >R SWAP R> SWAP ; \ : OVER >R DUP R> SWAP ; \ ROT cas 26jan06CODE ROT ( 16B1 16B2 16B3 -- 16B2 16B3 16B1) 3 # LDY SP )Y LDA N 1+ STA 1 # LDY SP )Y LDA 3 # LDY SP )Y STA 5 # LDY SP )Y LDA N STA N 1+ LDA SP )Y STA 1 # LDY N LDA SP )Y STA INY SP )Y LDA N 1+ STA SP X) LDA SP )Y STA 4 # LDY SP )Y LDA SP X) STA N 1+ LDA SP )Y STA 1 # LDY NEXT JMP END-CODE \ -ROT NIP UNDER PICK ROLL 24DEC83KS) cas 26jan06: -ROT ( 16B1 16B2 16B3 -- 16B3 16B1 16B2) ROT ROT ; : NIP ( 16B1 16B2 -- 16B2) SWAP DROP ; : UNDER ( 16B1 16B2 -- 16B2 16B1 16B2) SWAP OVER ; : PICK ( N -- 16B.N ) 1+ 2* SP@ + @ ; : ROLL ( N --) DUP >R PICK SP@ DUP 2+ R> 1+ 2* CMOVE> DROP ; \\ : -ROLL ( N --) >R DUP SP@ DUP 2+ DUP 2+ SWAP R@ 2* CMOVE R> 1+ 2* + ! ; \ DOUBLE WORD STACK MANIP. 21APR83KS) : 2SWAP ( 32B1 32B2 -- 32B2 32B1) ROT >R ROT R> ; CODE 2DROP ( 32B -- ) (2DROP HERE 2- ! END-CODE : 2DUP ( 32B -- 32B 32B) OVER OVER ; \ : 2DROP ( 32B -- ) DROP DROP ; \ + AND OR XOR 08APR85BP) COMPILER ASSEMBLER ALSO DEFINITIONS H : DYADOP ( OPCODE --) T INY SP X) LDA DUP C, SP C, SP )Y STA DEY SP )Y LDA 3 # LDY C, SP C, SP )Y STA (XYDROP JMP H ; TARGET CODE + ( N1 N2 -- N3) CLC 071 DYADOP END-CODE CODE OR ( 16B1 16B2 -- 16B3) 011 DYADOP END-CODE CODE AND ( 16B1 16B2 -- 16B3) 031 DYADOP END-CODE CODE XOR ( 16B1 16B2 -- 16B3) 051 DYADOP END-CODE \ - NOT NEGATE 24DEC83KS) CODE - ( N1 N2 -- N3) INY SP )Y LDA SEC SP X) SBC SP )Y STA INY SP )Y LDA 1 # LDY SP )Y SBC 3 # LDY SP )Y STA (XYDROP JMP END-CODE CODE NOT ( 16B1 -- 16B2) CLC LABEL (NOT TXA SP X) SBC SP X) STA TXA SP )Y SBC SP )Y STA NEXT JMP END-CODE CODE NEGATE ( N1 -- N2 ) SEC (NOT BCS END-CODE \ : - NEGATE + ; \ DNEGATE SETUP D+ 14JUN84KS) CODE DNEGATE ( D1 -- -D1) INY SEC TXA SP )Y SBC SP )Y STA INY TXA SP )Y SBC SP )Y STA TXA SP X) SBC SP X) STA 1 # LDY TXA SP )Y SBC SP )Y STA NEXT JMP END-CODE LABEL SETUP ( QUAN IN A) .A ASL TAX TAY DEY [[ SP )Y LDA N ,Y STA DEY 0< ?] TXA CLC SP ADC SP STA CS ?[ SP 1+ INC ]? 0 # LDX 1 # LDY RTS END-CODE \ D+ cas 26jan06CODE D+ ( D1 D2 -- D3) 2 # LDA SETUP JSR INY SP )Y LDA CLC N 2+ ADC SP )Y STA INY SP )Y LDA N 3 + ADC SP )Y STA SP X) LDA N ADC SP X) STA 1 # LDY SP )Y LDA N 1+ ADC SP )Y STA NEXT JMP END-CODE \ 1+ 2+ 3+ 1- 2- 08APR85BP) CODE 1+ ( N1 -- N2) 1 # LDA LABEL N+ CLC SP X) ADC CS NOT ?[ PUTA JMP ]? SP X) STA SP )Y LDA 0 # ADC SP )Y STA NEXT JMP END-CODE CODE 2+ ( N1 -- N2) 2 # LDA N+ BNE END-CODE CODE 3+ ( N1 -- N2) 3 # LDA N+ BNE END-CODE | CODE 4+ ( N1 -- N2) 4 # LDA N+ BNE END-CODE | CODE 6+ ( N1 -- N2) 6 # LDA N+ BNE END-CODE \ NUMBER CONSTANTS 24DEC83KS) CODE 1- ( N1 -- N2) SEC LABEL (1- SP X) LDA 1 # SBC CS ?[ PUTA JMP ]? SP X) STA SP )Y LDA 0 # SBC SP )Y STA NEXT JMP END-CODE CODE 2- ( N1 -- N2) CLC (1- BCC END-CODE -1 CONSTANT TRUE 0 CONSTANT FALSE ' TRUE ALIAS -1 ' FALSE ALIAS 0 1 CONSTANT 1 2 CONSTANT 2 3 CONSTANT 3 4 CONSTANT 4 : ON ( ADDR -- ) TRUE SWAP ! ; : OFF ( ADDR -- ) FALSE SWAP ! ; \ WORDS FOR NUMBER LITERALS 24MAY84KS) cs08aug05 CODE CLIT ( -- 8B) SP 2DEC IP X) LDA SP X) STA TXA SP )Y STA IP WINC NEXT JMP END-CODE RESTRICT CODE LIT ( -- 16B) SP 2DEC IP )Y LDA SP )Y STA IP X) LDA SP X) STA LABEL (BUMP IP 2INC NEXT JMP END-CODE RESTRICT : LITERAL ( 16B --) DUP 0FF00 AND IF COMPILE LIT , EXIT THEN COMPILE CLIT C, ; IMMEDIATE RESTRICT \\ : LIT R> DUP 2+ >R @ ; : CLIT R> DUP 1+ >R C@ ; \ COMPARISION CODE WORDS 13JUN84KS) CODE 0< ( N -- FLAG) SP )Y LDA 0< ?[ LABEL PUTTRUE 0FF # LDA 024 C, ]? LABEL PUTFALSE TXA SP )Y STA PUTA JMP END-CODE CODE 0= ( 16B -- FLAG) SP X) LDA SP )Y ORA PUTTRUE BEQ PUTFALSE BNE END-CODE CODE UWITHIN ( U1 [LOW UP[ -- FLAG) 2 # LDA SETUP JSR 1 # LDY SP X) LDA N CMP SP )Y LDA N 1+ SBC CS NOT ?[ ( N>SP) SP X) LDA N 2+ CMP SP )Y LDA N 3 + SBC PUTTRUE BCS ]? PUTFALSE JMP END-CODE \ COMPARISION CODE WORDS 13JUN84KS) CODE < ( N1 N2 -- FLAG) SP X) LDA N STA SP )Y LDA N 1+ STA SP 2INC N 1+ LDA SP )Y EOR ' 0< @ BMI SP X) LDA N CMP SP )Y LDA N 1+ SBC ' 0< @ 2+ JMP END-CODE CODE U< ( U1 U2 -- FLAG) SP X) LDA N STA SP )Y LDA N 1+ STA SP 2INC SP X) LDA N CMP SP )Y LDA N 1+ SBC CS NOT ?[ PUTTRUE JMP ]? PUTFALSE JMP END-CODE \ COMPARISION WORDS 24DEC83KS) cas 02aug2020 | : 0< 8000 AND 0<> ; : > ( N1 N2 -- FLAG) SWAP < ; : 0> ( N -- FLAG) DUP 0< SWAP 0= OR NOT ; : 0<> ( N -- FLAG) 0= NOT ; : U> ( U1 U2 -- FLAG) SWAP U< ; : = ( N1 N2 -- FLAG) - 0= ; : D0= ( D -- FLAG) OR 0= ; : D= ( D1 D2 -- FLAG) DNEGATE D+ D0= ; : D< ( D1 D2 -- FLAG) ROT 2DUP - IF > NIP NIP ELSE 2DROP U< THEN ; \ MIN MAX UMAX UMIN EXTEND DABS ABS cas 26jan06 | : MINIMAX ( N1 N2 FLAG -- N3) RDROP IF SWAP THEN DROP ; : MIN ( N1 N2 -- N3) 2DUP > MINIMAX ; -2 ALLOT : MAX ( N1 N2 -- N3) 2DUP < MINIMAX ; -2 ALLOT : UMAX ( U1 U2 -- U3) 2DUP U< MINIMAX ; -2 ALLOT : UMIN ( U1 U2 -- U3) 2DUP U> MINIMAX ; -2 ALLOT : EXTEND ( N -- D) DUP 0< ; : DABS ( D -- UD) EXTEND IF DNEGATE THEN ; : ABS ( N -- U) EXTEND IF NEGATE THEN ; \ LOOP PRIMITIVES 08FEB85BP/KS) | : DODO RDROP R> 2+ DUP >R ROT >R SWAP >R >R ; : (DO ( LIMIT STAR -- ) OVER - DODO ; -2 ALLOT RESTRICT : (?DO ( LIMIT START -- ) OVER - ?DUP IF DODO THEN R> DUP @ + >R DROP ; RESTRICT : BOUNDS ( START COUNT -- LIMIT START ) OVER + SWAP ; CODE ENDLOOP 6 # LDA (NRDROP JMP END-CODE RESTRICT \\ DODO PUTS "INDEX \ LIMIT \ ADR.OF.DO" ON RETURN-STACK \ (LOOP (+LOOP 08APR85BP) CODE (LOOP CLC 1 # LDA RP X) ADC RP X) STA CS ?[ RP )Y LDA 0 # ADC RP )Y STA CS ?[ NEXT JMP ]? ]? LABEL DOLOOP 5 # LDY RP )Y LDA IP 1+ STA DEY RP )Y LDA IP STA 1 # LDY NEXT JMP END-CODE RESTRICT CODE (+LOOP CLC SP X) LDA RP X) ADC RP X) STA SP )Y LDA RP )Y ADC RP )Y STA .A ROR SP )Y EOR PHP SP 2INC PLP DOLOOP BPL NEXT JMP END-CODE RESTRICT \ LOOP INDICES 08APR85BP) CODE I ( -- N) 0 # LDY LABEL LOOPINDEX SP 2DEC CLC RP )Y LDA INY INY RP )Y ADC SP X) STA DEY RP )Y LDA INY INY RP )Y ADC 1 # LDY SP )Y STA NEXT JMP END-CODE RESTRICT CODE J ( -- N) 6 # LDY LOOPINDEX BNE END-CODE RESTRICT \ BRANCHING 24DEC83KS) CODE BRANCH CLC IP LDA IP X) ADC N STA IP 1+ LDA IP )Y ADC IP 1+ STA N LDA IP STA NEXT JMP END-CODE RESTRICT CODE ?BRANCH SP X) LDA SP )Y ORA PHP SP 2INC PLP ' BRANCH @ BEQ (BUMP JMP END-CODE RESTRICT \\ : BRANCH R> DUP @ + >R ; RESTRICT : ?BRANCH 0= R> OVER NOT OVER 2+ AND -ROT DUP @ + AND OR >R ; RESTRICT \ RESOLVE LOOPS AND BRANCHES 03FEB85BP) : >MARK ( -- ADDR) HERE 0 , ; : >RESOLVE ( ADDR --) HERE OVER - SWAP ! ; : MARK 1 ; IMMEDIATE RESTRICT : THEN ABS 1 ?PAIRS >RESOLVE ; IMMEDIATE RESTRICT : ELSE 1 ?PAIRS COMPILE BRANCH >MARK SWAP >RESOLVE -1 ; IMMEDIATE RESTRICT : BEGIN MARK -2 2SWAP ; IMMEDIATE RESTRICT | : (REPTIL RESOLVE REPEAT ; : REPEAT 2 ?PAIRS COMPILE BRANCH (REPTIL ; IMMEDIATE RESTRICT : UNTIL 2 ?PAIRS COMPILE ?BRANCH (REPTIL ; IMMEDIATE RESTRICT \ LOOPS 29JAN85KS/BP) : DO COMPILE (DO >MARK 3 ; IMMEDIATE RESTRICT : ?DO COMPILE (?DO >MARK 3 ; IMMEDIATE RESTRICT : LOOP 3 ?PAIRS COMPILE (LOOP COMPILE ENDLOOP >RESOLVE ; IMMEDIATE RESTRICT : +LOOP 3 ?PAIRS COMPILE (+LOOP COMPILE ENDLOOP >RESOLVE ; IMMEDIATE RESTRICT : LEAVE ENDLOOP R> 2- DUP @ + >R ; RESTRICT \\ RETURNSTACK: CALLADR \ INDEX LIMIT \ ADR OF DO \ UM* BP/KS13.2.85) CODE UM* ( U1 U2 -- UD) SP )Y LDA N STA SP X) LDA N 1+ STA INY N 2 + STX N 3 + STX 010 # LDX [[ N 3 + ASL N 2+ ROL N 1+ ROL N ROL CS ?[ CLC SP )Y LDA N 3 + ADC N 3 + STA INY SP )Y LDA DEY N 2 + ADC N 2 + STA CS ?[ N 1+ INC 0= ?[ N INC ]? ]? ]? DEX 0= ?] N 3 + LDA SP )Y STA INY N 2 + LDA SP )Y STA 1 # LDY N LDA SP )Y STA N 1+ LDA SP X) STA NEXT JMP END-CODE \\ : UM* ( U1 U2 -- UD3) >R 0 0 0 R> 010 0 DO DUP 2/ >R 1 AND IF 2OVER D+ THEN >R >R 2DUP D+ R> R> R> LOOP DROP 2SWAP 2DROP ; \ M* 2* 04JUL84KS) : M* ( N1 N2 -- D) DUP 0< DUP >R IF NEGATE THEN SWAP DUP 0< IF NEGATE R> NOT >R THEN UM* R> IF DNEGATE THEN ; : * ( N N -- PROD) UM* DROP ; CODE 2* ( N1 -- N2) SP X) LDA .A ASL SP X) STA SP )Y LDA .A ROL SP )Y STA NEXT JMP END-CODE | : 2* DUP + ; \ UM/MOD 04JUL84KS) | : DIVOVL TRUE ABORT" DIVISION OVERFLOW" ; CODE UM/MOD ( UD U -- UREM UQUOT) SP X) LDA N 5 + STA SP )Y LDA N 4 + STA SP 2INC SP X) LDA N 1+ STA SP )Y LDA N STA INY SP )Y LDA N 3 + STA INY SP )Y LDA N 2+ STA 011 # LDX CLC [[ N 6 + ROR SEC N 1+ LDA N 5 + SBC TAY N LDA N 4 + SBC CS NOT ?[ N 6 + ROL ]? CS ?[ N STA N 1+ STY ]? \ N 3 + ROL N 2+ ROL N 1+ ROL N ROL DEX 0= ?] 1 # LDY N ROR N 1+ ROR CS ?[ ;C: DIVOVL ; ASSEMBLER ]? N 2+ LDA SP )Y STA INY N 1+ LDA SP )Y STA INY N LDA SP )Y STA 1 # LDY N 3 + LDA PUTA JMP END-CODE \ 2/ M/MOD 24DEC83KS) : M/MOD ( D N -- MOD QUOT) DUP >R ABS OVER 0< IF UNDER + SWAP THEN UM/MOD R@ 0< IF NEGATE OVER IF SWAP R@ + SWAP 1- THEN THEN RDROP ; CODE 2/ ( N1 -- N2) SP )Y LDA .A ASL SP )Y LDA .A ROR SP )Y STA SP X) LDA .A ROR PUTA JMP END-CODE \ /MOD / MOD */MOD */ U/MOD UD/MOD KS) : /MOD ( N1 N2 -- REM QUOT) >R EXTEND R> M/MOD ; : / ( N1 N2 -- QUOT) /MOD NIP ; : MOD ( N1 N2 -- REM) /MOD DROP ; : */MOD ( N1 N2 N3 -- REM QUOT) >R M* R> M/MOD ; : */ ( N1 N2 N3 -- QUOT) */MOD NIP ; : U/MOD ( U1 U2 -- UREM UQUOT) 0 SWAP UM/MOD ; : UD/MOD ( UD1 U2 -- UREM UDQUOT) >R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ; \ CMOVE CMOVE> (CMOVE> BP 08APR85) CODE CMOVE ( FROM TO QUAN --) 3 # LDA SETUP JSR DEY [[ [[ N CPY 0= ?[ N 1+ DEC 0< ?[ 1 # LDY NEXT JMP ]? ]? N 4 + )Y LDA N 2+ )Y STA INY 0= ?] N 5 + INC N 3 + INC ]] END-CODE \ CMOVE> MOVE cas 26jan06CODE CMOVE> ( FROM TO QUAN --) 3 # LDA SETUP JSR CLC N 1+ LDA N 3 + ADC N 3 + STA CLC N 1+ LDA N 5 + ADC N 5 + STA N 1+ INC N LDY CLC CS ?[ LABEL (CMOVE> DEY N 4 + )Y LDA N 2+ )Y STA ]? TYA (CMOVE> BNE N 3 + DEC N 5 + DEC N 1+ DEC (CMOVE> BNE 1 # LDY NEXT JMP END-CODE : MOVE ( FROM TO QUAN --) >R 2DUP U< IF R> CMOVE> EXIT THEN R> CMOVE ; \ PLACE COUNT ERASE 16FEB85BP/KS) : PLACE ( ADDR LEN TO --) OVER >R ROT OVER 1+ R> MOVE C! ; CODE COUNT ( ADDR -- ADDR+1 LEN) SP X) LDA N STA CLC 1 # ADC SP X) STA SP )Y LDA N 1+ STA 0 # ADC SP )Y STA SP 2DEC (C@ JMP END-CODE \ : COUNT ( ADR -- ADR+1 LEN ) DUP 1+ SWAP C@ ; : ERASE ( ADDR QUAN --) 0 FILL ; \ FILL 11JUN85BP) CODE FILL ( ADDR QUAN 8B -- ) 3 # LDA SETUP JSR DEY N LDA N 3 + LDX 0<> ?[ [[ [[ N 4 + )Y STA INY 0= ?] N 5 + INC DEX 0= ?] ]? N 2+ LDX 0<> ?[ [[ N 4 + )Y STA INY DEX 0= ?] ]? 1 # LDY NEXT JMP END-CODE \\ : FILL ( ADDR QUAN 8B --) SWAP ?DUP IF >R OVER C! DUP 1+ R> 1- CMOVE EXIT THEN 2DROP ; \ HERE PAD ALLOT , C, COMPILE 24DEC83KS) : HERE ( -- ADDR) DP @ ; : PAD ( -- ADDR) HERE 042 + ; : ALLOT ( N --) DP +! ; : , ( 16B --) HERE ! 2 ALLOT ; : C, ( 8B --) HERE C! 1 ALLOT ; : COMPILE R> DUP 2+ >R @ , ; RESTRICT \ INPUT STRINGS 24DEC83KS) VARIABLE #TIB 0 #TIB ! VARIABLE >TIB $100 >TIB ! \ 050 ALLOT VARIABLE >IN 0 >IN ! VARIABLE BLK 0 BLK ! VARIABLE SPAN 0 SPAN ! : TIB ( -- ADDR ) >TIB @ ; : QUERY TIB 050 EXPECT SPAN @ #TIB ! >IN OFF BLK OFF ; \ SCAN SKIP /STRING 12OCT84BP) : SCAN ( ADDR0 LEN0 CHAR -- ADDR1 LEN1) >R BEGIN DUP WHILE OVER C@ R@ - WHILE 1- SWAP 1+ SWAP REPEAT RDROP ; : SKIP ( ADDR LEN DEL -- ADDR1 LEN1) >R BEGIN DUP WHILE OVER C@ R@ = WHILE 1- SWAP 1+ SWAP REPEAT RDROP ; : /STRING ( ADDR0 LEN0 +N - ADDR1 LEN1) OVER UMIN ROT OVER + -ROT - ; \ CAPITAL 03APR85BP) (C LABEL (CAPITAL \ FOR COMMODORE ONLY PHA 0DF # AND \ 2ND UPPER TO LOWER ASCII A # CMP CS ?[ ASCII Z 1+ # CMP CC ?[ PLA CLC ASCII A ASCII A - # ADC RTS ]? ]? PLA RTS END-CODE ) LABEL (CAPITAL \ FOR ASCII ONLY ASCII a # CMP CS ?[ ASCII z 1+ # CMP CC ?[ SEC ASCII a ASCII A - # SBC ]? ]? RTS END-CODE CODE CAPITAL ( CHAR -- CHAR' ) SP X) LDA (CAPITAL JSR SP X) STA NEXT JMP END-CODE \ CAPITALIZE 03APR85BP) CODE CAPITALIZE ( STRING -- STRING ) SP X) LDA N STA SP )Y LDA N 1+ STA N X) LDA N 2+ STA DEY [[ N 2+ CPY 0= ?[ 1 # LDY NEXT JMP ]? INY N )Y LDA (CAPITAL JSR N )Y STA ]] END-CODE \\ : CAPITALIZE ( STRING -- STRING ) DUP COUNT BOUNDS ?DO I C@ CAPITAL I C! THEN LOOP ; \\ CAPITAL ( CHAR -- CHAR ) ASCII A ASCII Z 1+ UWITHIN IF I C@ [ ASCII A ASCII A - ] LITERAL - ; \ (WORD 08APR85BP) | CODE (WORD ( CHAR ADR0 LEN0 -- ADR) \ N : LENGTH OF SOURCE \ N+2 : PTR IN SOURCE / NEXT CHAR \ N+4 : STRING START ADRESS \ N+6 : STRING LENGTH N 6 + STX \ 0 =: STRING_LENGTH 3 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] 1 # LDY CLC >IN LDA N 2+ ADC N 2+ STA \ >IN+ADR0 =: N+2 >IN 1+ LDA N 3 + ADC N 3 + STA SEC N LDA >IN SBC N STA \ LEN0->IN =: N N 1+ LDA >IN 1+ SBC N 1+ STA CC ?[ SP X) LDA >IN STA \ STREAM EXHAUSTED SP )Y LDA >IN 1+ STA \ (WORD 08APR85BP) ][ 4 # LDY [[ N LDA N 1+ ORA \ SKIP CHAR'S 0= NOT ?[[ N 2+ X) LDA SP )Y CMP \ WHILE COUNT <>0 0= ?[[ N 2+ WINC N WDEC ]]? N 2+ LDA N 4 + STA \ SAVE STRING_START_ADRESS N 3 + LDA N 5 + STA [[ N 2+ X) LDA SP )Y CMP PHP \ SCAN FOR CHAR N 2+ WINC N WDEC PLP 0= NOT ?[[ N 6 + INC \ COUNT STRING_LENGTH N LDA N 1+ ORA 0= ?] ]? ]? \ FROM COUNT = 0 IN SKIP) SEC 2 # LDY \ ADR_AFTER_STRING - ADR0 =: >IN) N 2+ LDA SP )Y SBC >IN STA INY N 3 + LDA SP )Y SBC >IN 1+ STA \ (WORD 08APR85BP) ]? \ FROM 1ST ][, STREAM WAS EXHAUSTED \ WHEN WORD CALLED) CLC 4 # LDA SP ADC SP STA CS ?[ SP 1+ INC ]? \ 2DROP USER' DP # LDY UP )Y LDA SP X) STA N STA INY UP )Y LDA 1 # LDY SP )Y STA N 1+ STA \ DP @ DEY N 6 + LDA \ STORE COUNT BYTE FIRST [[ N )Y STA N 4 + )Y LDA INY N 6 + DEC 0< ?] 020 # LDA N )Y STA \ ADD A BLANK 1 # LDY NEXT JMP END-CODE \ SOURCE WORD PARSE NAME 08APR85BP) : SOURCE ( -- ADDR LEN) BLK @ ?DUP IF BLOCK B/BLK EXIT THEN TIB #TIB @ ; : WORD ( CHAR -- ADDR) SOURCE (WORD ; : PARSE ( CHAR -- ADDR LEN) >R SOURCE >IN @ /STRING OVER SWAP R> SCAN >R OVER - DUP R> 0<> - >IN +! ; : NAME ( -- ADDR) BL WORD CAPITALIZE EXIT ; \\ : WORD ( CHAR -- ADDR) >R SOURCE OVER SWAP >IN @ /STRING R@ SKIP OVER SWAP R> SCAN >R ROT OVER SWAP - R> 0<> - >IN ! OVER - HERE PLACE BL HERE COUNT + C! HERE ; \ STATE ASCII ," (" " 24DEC83KS) VARIABLE STATE 0 STATE ! : ASCII BL WORD 1+ C@ STATE @ IF [COMPILE] LITERAL THEN ; IMMEDIATE : ," ASCII " PARSE HERE OVER 1+ ALLOT PLACE ; : "LIT R> R> UNDER COUNT + >R >R ; RESTRICT : (" "LIT ; RESTRICT : " COMPILE (" ," ; IMMEDIATE RESTRICT \ ." ( .( \ \\ HEX DECIMAL 08SEP84KS) : (." "LIT COUNT TYPE ; RESTRICT : ." COMPILE (." ," ; IMMEDIATE RESTRICT : ( ASCII ) PARSE 2DROP ; IMMEDIATE : .( ASCII ) PARSE TYPE ; IMMEDIATE : \ >IN @ C/L / 1+ C/L * >IN ! ; IMMEDIATE : \\ B/BLK >IN ! ; IMMEDIATE : \NEEDS NAME FIND NIP IF [COMPILE] \ THEN ; : HEX 010 BASE ! ; : DECIMAL 0A BASE ! ; \ NUMBER CONV.: DIGIT? ACCUMULATE KS) : DIGIT? ( CHAR -- DIGIT TRUE/ FALSE ) ASCII 0 - DUP 9 U> IF [ ASCII A ASCII 9 - 1- ] LITERAL - DUP 9 U> IF [ 2SWAP ( UNSTRUKTURIERT) ] THEN BASE @ OVER U> ?DUP ?EXIT THEN DROP FALSE ; : ACCUMULATE ( +D0 ADR DIGIT - +D1 ADR) SWAP >R SWAP BASE @ UM* DROP ROT BASE @ UM* D+ R> ; : CONVERT ( +D1 ADDR0 -- +D2 ADDR2) 1+ BEGIN COUNT DIGIT? WHILE ACCUMULATE REPEAT 1- ; | : END? ( -- FLAG ) PTR @ 0= ; | : CHAR ( ADDR0 -- ADDR1 CHAR ) COUNT -1 PTR +! ; | : PREVIOUS ( ADDR0 -- ADDR0 CHAR) 1- COUNT ; \ ?NONUM ?NUM FIXBASE? 13FEB85KS) VARIABLE DPL -1 DPL ! | : ?NONUM ( FLAG -- EXIT IF TRUE ) IF RDROP 2DROP DROP RDROP FALSE THEN ; | : ?NUM ( FLAG -- EXIT IF TRUE ) IF RDROP DROP R> IF DNEGATE THEN ROT DROP DPL @ 1+ ?DUP ?EXIT DROP TRUE THEN ; | : FIXBASE? ( CHAR - CHAR FALSE / NEWBASE TRUE ) ASCII & CASE? IF 0A TRUE EXIT THEN ASCII $ CASE? IF 10 TRUE EXIT THEN ASCII H CASE? IF 10 TRUE EXIT THEN ASCII % CASE? IF 2 TRUE EXIT THEN FALSE ; \ 13FEB85KS) | : PUNCTUATION? ( CHAR -- FLAG) ASCII , OVER = SWAP ASCII . = OR ; | : ?DPL DPL @ -1 = ?EXIT 1 DPL +! ; | VARIABLE PTR \ POINTS INTO STRING \ (NUMBER NUMBER 13FEB85KS) : NUMBER? ( STRING - STRING FALSE / N 0< / D 0> ) BASE PUSH DUP COUNT PTR ! DPL ON 0 >R ( +SIGN) 0.0 ROT END? ?NONUM CHAR ASCII - CASE? IF RDROP TRUE >R END? ?NONUM CHAR THEN FIXBASE? IF BASE ! END? ?NONUM CHAR THEN BEGIN DIGIT? 0= ?NONUM BEGIN ACCUMULATE ?DPL END? ?NUM CHAR DIGIT? 0= UNTIL PREVIOUS PUNCTUATION? 0= ?NONUM DPL OFF END? ?NUM CHAR REPEAT ; : NUMBER ( STRING -- D ) NUMBER? ?DUP 0= ABORT" ?" 0< IF EXTEND THEN ; \ HIDE REVEAL IMMEDIATE RESTRICT KS) VARIABLE LAST 0 LAST ! | : LAST? ( -- FALSE / ACF TRUE) LAST @ ?DUP ; : HIDE LAST? IF 2- @ CURRENT @ ! THEN ; : REVEAL LAST? IF 2- CURRENT @ ! THEN ; : RECURSIVE REVEAL ; IMMEDIATE RESTRICT | : FLAG! ( 8B --) LAST? IF UNDER C@ OR OVER C! THEN DROP ; : IMMEDIATE 040 FLAG! ; : RESTRICT 080 FLAG! ; \ CLEARSTACK HALLOT HEAP HEAP? cas 26jan06 CODE CLEARSTACK USER' S0 # LDY UP )Y LDA SP STA INY UP )Y LDA SP 1+ STA 1 # LDY NEXT JMP END-CODE : HALLOT ( QUAN -- ) S0 @ OVER - SWAP SP@ 2+ DUP ROT - DUP S0 ! 2 PICK OVER - MOVE CLEARSTACK S0 ! ; : HEAP ( -- ADDR) S0 @ 6+ ; : HEAP? ( ADDR -- FLAG) HEAP UP@ UWITHIN ; | : HEAPMOVE ( FROM -- FROM) DUP HERE OVER - DUP HALLOT HEAP SWAP CMOVE HEAP OVER - LAST +! REVEAL ; \ DOES> ; 30DEC84KS/BP) LABEL (DODOES> RP 2DEC IP 1+ LDA RP )Y STA IP LDA RP X) STA \ PUT IP ON RP CLC W X) LDA 3 # ADC IP STA TXA W )Y ADC IP 1+ STA \ W@ + 3 -> IP LABEL DOCREATE 2 # LDA CLC W ADC PHA TXA W 1+ ADC PUSH JMP END-CODE | : (;CODE R> LAST @ NAME> ! ; : DOES> COMPILE (;CODE 04C C, COMPILE (DODOES> ; IMMEDIATE RESTRICT \ 6502-ALIGN ?HEAD \ 08SEP84BP) | : 6502-ALIGN/1 ( ADR -- ADR' ) DUP 0FF AND 0FF = - ; | : 6502-ALIGN/2 ( LFA -- LFA ) HERE 0FF AND 0FF = IF DUP DUP 1+ HERE OVER - 1+ CMOVE> \ LFA NOW INVALID 1 LAST +! 1 ALLOT THEN ; VARIABLE ?HEAD 0 ?HEAD ! : | ?HEAD @ ?EXIT -1 ?HEAD ! ; \ WARNING CREATE 30DEC84BP) VARIABLE WARNING 0 WARNING ! | : EXISTS? WARNING @ ?EXIT LAST @ CURRENT @ (FIND NIP IF SPACE LAST @ .NAME ." EXISTS " ?CR THEN ; : CREATE HERE BLK @ , CURRENT @ @ , NAME C@ DUP 1 020 UWITHIN NOT ABORT" INVALID NAME" HERE LAST ! 1+ ALLOT EXISTS? ?HEAD @ IF 1 ?HEAD +! DUP 6502-ALIGN/1 , \ POINTER TO CODE HEAPMOVE 020 FLAG! 6502-ALIGN/1 DP ! ELSE 6502-ALIGN/2 DROP THEN REVEAL 0 , ;CODE DOCREATE JMP END-CODE \ NFA? 30DEC84BP) | CODE NFA? ( VOCABTHREAD CFA -- NFA / FALSE) SP X) LDA N 4 + STA SP )Y LDA N 5 + STA SP 2INC [[ [[ SP X) LDA N 2+ STA SP )Y LDA N 3 + STA N 2+ ORA 0= ?[ PUTFALSE JMP ]? N 2+ )Y LDA SP )Y STA N 1+ STA N 2+ X) LDA SP X) STA N STA N 1+ ORA 0= ?[ NEXT JMP ]? \ N=LINK N 2INC N X) LDA PHA SEC 01F # AND N ADC N STA CS ?[ N 1+ INC ]? PLA 020 # AND 0= NOT ?[ N )Y LDA PHA N X) LDA N STA PLA N 1+ STA ]? N LDA N 4 + CMP 0= ?] \ VOCABTHREAD=0 N 1+ LDA N 5 + CMP 0= ?] \ D.H. LEERES VOCABULARY ' 2+ @ JMP END-CODE \ IN NFA? IST ERLAUBT \ >NAME NAME> >BODY .NAME 03FEB85BP) : >NAME ( CFA -- NFA / FALSE) VOC-LINK BEGIN @ DUP WHILE 2DUP 4 - SWAP NFA? ?DUP IF -ROT 2DROP EXIT THEN REPEAT NIP ; | : (NAME> ( NFA -- CFA) COUNT 01F AND + ; : NAME> ( NFA -- CFA) DUP (NAME> SWAP C@ 020 AND IF @ THEN ; : >BODY ( CFA -- PFA) 2+ ; : .NAME ( NFA --) ?DUP IF DUP HEAP? IF ." |" THEN COUNT 01F AND TYPE ELSE ." ???" THEN SPACE ; \ : ; CONSTANT VARIABLE 09JAN85KS/BP) : : CREATE HIDE CURRENT @ CONTEXT ! ] 0 ;CODE HERE >RECOVER ! \ RESOLVE FWD. REFERENCE RP 2DEC IP LDA RP X) STA IP 1+ LDA RP )Y STA W LDA CLC 2 # ADC IP STA TXA W 1+ ADC IP 1+ STA NEXT JMP END-CODE : ; 0 ?PAIRS COMPILE EXIT [COMPILE] [ REVEAL ; IMMEDIATE RESTRICT : CONSTANT ( 16B --) CREATE , ;CODE SP 2DEC 2 # LDY W )Y LDA SP X) STA INY W )Y LDA 1 # LDY SP )Y STA NEXT JMP END-CODE : VARIABLE CREATE 2 ALLOT ; \ UALLOT USER ALIAS 10JAN85KS/BP) : UALLOT ( QUAN -- OFFSET) DUP UDP @ + 0FF U> ABORT" USERAREA FULL" UDP @ SWAP UDP +! ; : USER CREATE 2 UALLOT C, ;CODE SP 2DEC 2 # LDY W )Y LDA CLC UP ADC SP X) STA TXA INY UP 1+ ADC 1 # LDY SP )Y STA NEXT JMP END-CODE : ALIAS ( CFA --) CREATE LAST @ DUP C@ 020 AND IF -2 ALLOT ELSE 020 FLAG! THEN (NAME> ! ; \ VOC-LINK VP CURRENT CONTEXT ALSO BP) CREATE VP 10 ALLOT VARIABLE CURRENT : CONTEXT ( -- ADR ) VP DUP @ + 2+ ; | : THRU.VOCSTACK ( -- FROM TO ) VP 2+ CONTEXT ; \ "ONLY FORTH ALSO ASSEMBLER" GIVES VP : \ COUNTWORD = 6 \ONLY\FORTH\ASSEMBLER : ALSO VP @ 0A > ERROR" VOCABULARY STACK FULL" CONTEXT @ 2 VP +! CONTEXT ! ; : TOSS -2 VP +! ; \ VOCABULARY FORTH ONLY FORTH-83 KS/BP) : VOCABULARY CREATE 0 , 0 , HERE VOC-LINK @ , VOC-LINK ! DOES> CONTEXT ! ; \ NAME \ CODE \ THREAD \ COLDTHREAD \ VOC-LINK VOCABULARY FORTH VOCABULARY ONLY ] DOES> [ ONLYPATCH ] 0 VP ! CONTEXT ! ALSO ; ' ONLY ! : ONLYFORTH ONLY FORTH ALSO DEFINITIONS ; \ DEFINITIONS ORDER WORDS 13JAN84BP/KS) : DEFINITIONS CONTEXT @ CURRENT ! ; | : .VOC ( ADR -- ) @ 2- >NAME .NAME ; : ORDER THRU.VOCSTACK DO I .VOC -2 +LOOP 2 SPACES CURRENT .VOC ; : WORDS CONTEXT @ BEGIN @ DUP STOP? 0= AND WHILE ?CR DUP 2+ .NAME SPACE REPEAT DROP ; \ (FIND 08APR85BP) CODE (FIND ( STRING THREAD -- STRING FALSE / NAMEFIELD TRUE) 3 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] N 2+ X) LDA 01F # AND N 4 + STA LABEL FINDLOOP 0 # LDY N )Y LDA TAX INY N )Y LDA N 1+ STA N STX N ORA 0= ?[ 1 # LDY 0 # LDX PUTFALSE JMP ]? INY N )Y LDA 01F # AND N 4 + CMP FINDLOOP BNE \ COUNTBYTE MATCH CLC 2 # LDA N ADC N 5 + STA 0 # LDA N 1+ ADC N 6 + STA N 4 + LDY [[ N 2+ )Y LDA N 5 + )Y CMP \ FINDLOOP BNE DEY 0= ?] 3 # LDY N 6 + LDA SP )Y STA DEY N 5 + LDA SP )Y STA DEY 0 # LDX PUTTRUE JMP END-CODE \ FOUND 29JAN85BP) | CODE FOUND ( NFA -- CFA N ) SP X) LDA N STA SP )Y LDA N 1+ STA N X) LDA N 2+ STA 01F # AND SEC N ADC N STA CS ?[ N 1+ INC ]? N 2+ LDA 020 # AND 0= ?[ N LDA SP X) STA N 1+ LDA ][ N X) LDA SP X) STA N )Y LDA ]? SP )Y STA SP 2DEC N 2+ LDA 0< ?[ INY ]? .A ASL 0< NOT ?[ TYA 0FF # EOR TAY INY ]? TYA SP X) STA 0< ?[ 0FF # LDA 24 C, ]? TXA 1 # LDY SP )Y STA NEXT JMP END-CODE \\ | : FOUND ( NFA -- CFA N ) DUP C@ >R (NAME> R@ 020 AND IF @ THEN -1 R@ 080 AND IF 1- THEN R> 040 AND IF NEGATE THEN ; \ FIND ' ['] 13JAN85BP) : FIND ( STRING -- CFA N / STRING FALSE) CONTEXT DUP @ OVER 2- @ = IF 2- THEN BEGIN UNDER @ (FIND IF NIP FOUND EXIT THEN OVER VP 2+ U> WHILE SWAP 2- REPEAT NIP FALSE ; : ' ( -- CFA ) NAME FIND 0= ABORT" HAEH?" ; : [COMPILE] ' , ; IMMEDIATE RESTRICT : ['] ' [COMPILE] LITERAL ; IMMEDIATE RESTRICT : NULLSTRING? ( STRING -- STRING FALSE / TRUE) DUP C@ 0= DUP IF NIP THEN ; \ >INTERPRET 28FEB85BP) LABEL JUMP INY CLC W )Y LDA 2 # ADC IP STA INY W )Y LDA 0 # ADC IP 1+ STA 1 # LDY NEXT JMP END-CODE VARIABLE >INTERPRET JUMP ' >INTERPRET ! \\ MAKE VARIABLE >INTERPRET TO SPECIAL DEFER \ INTERPRET INTERACTIVE 31DEC84KS/BP) cas 26jan06 DEFER NOTFOUND : NO.EXTENSIONS ( STRING -- ) ERROR" WHAT?" ; \ STRING NOT 0 ' NO.EXTENSIONS IS NOTFOUND : INTERPRET >INTERPRET ; -2 ALLOT | : INTERACTIVE ?STACK NAME FIND ?DUP IF 1 AND IF EXECUTE >INTERPRET THEN ABORT" COMPILE ONLY" THEN NULLSTRING? ?EXIT NUMBER? 0= IF NOTFOUND THEN >INTERPRET ; -2 ALLOT ' INTERACTIVE >INTERPRET ! \ COMPILING [ ] 20DEC84BP) | : COMPILING ?STACK NAME FIND ?DUP IF 0> IF EXECUTE >INTERPRET THEN , >INTERPRET THEN NULLSTRING? ?EXIT NUMBER? ?DUP IF 0> IF SWAP [COMPILE] LITERAL THEN [COMPILE] LITERAL ELSE NOTFOUND THEN >INTERPRET ; -2 ALLOT : [ ['] INTERACTIVE IS >INTERPRET STATE OFF ; IMMEDIATE : ] ['] COMPILING IS >INTERPRET STATE ON ; \ PERFOM DEFER IS 03FEB85BP) | : CRASH TRUE ABORT" CRASH" ; : DEFER CREATE ['] CRASH , ;CODE 2 # LDY W )Y LDA PHA INY W )Y LDA W 1+ STA PLA W STA 1 # LDY W 1- JMP END-CODE : (IS R> DUP 2+ >R @ ! ; | : DEF? ( CFA -- ) @ ['] NOTFOUND @ OVER = SWAP ['] >INTERPRET @ = OR NOT ABORT" NOT DEFERRED" ; : IS ( ADR -- ) ' DUP DEF? >BODY STATE @ IF COMPILE (IS , EXIT THEN ! ; IMMEDIATE \ ?STACK 08SEP84KS) cas 15july2020 | : STACKFULL ( -- ) DEPTH 20 > ABORT" TIGHT STACK" REVEAL LAST? IF DUP HEAP? IF NAME> ELSE 4 - THEN (FORGET THEN TRUE ABORT" DICTIONARY FULL" ; CODE ?STACK USER' DP # LDY SEC SP LDA UP )Y SBC N STA INY SP 1+ LDA UP )Y SBC 0= ?[ 1 # LDY ;C: STACKFULL ; ASSEMBLER ]? USER' S0 # LDY UP )Y LDA SP CMP INY UP )Y LDA SP 1+ SBC 1 # LDY CS ?[ NEXT JMP ]? ;C: TRUE ABORT" STACK EMPTY" ; -2 ALLOT \\ : ?STACK SP@ HERE - 100 U< IF STACKFULL THEN SP@ S0 @ U> ABORT" STACK EMPTY" ; \ .STATUS PUSH LOAD 08SEP84KS) DEFER .STATUS ' NOOP IS .STATUS | CREATE PULL 0 ] R> R> ! ; : PUSH ( ADDR -- ) R> SWAP DUP >R @ >R PULL >R >R ; RESTRICT : LOAD ( BLK --) ?DUP 0= ?EXIT BLK PUSH BLK ! >IN PUSH >IN OFF .STATUS INTERPRET ; \ +LOAD THRU +THRU --> RDEPTH DEPTH KS) : +LOAD ( OFFSET --) BLK @ + LOAD ; : THRU ( FROM TO --) 1+ SWAP DO I LOAD LOOP ; : +THRU ( OFF0 OFF1 --) 1+ SWAP DO I +LOAD LOOP ; : --> 1 BLK +! >IN OFF .STATUS ; IMMEDIATE : RDEPTH ( -- +N) R0 @ RP@ 2+ - 2/ ; : DEPTH ( -- +N) SP@ S0 @ SWAP - 2/ ; \ QUIT (QUIT ABORT 07JUN85BP) | : PROMPT STATE @ IF ." COMPILING" EXIT THEN ." OK" ; : (QUIT BEGIN .STATUS CR QUERY INTERPRET PROMPT REPEAT ; -2 ALLOT DEFER 'QUIT ' (QUIT IS 'QUIT : QUIT R0 @ RP! [COMPILE] [ 'QUIT ; -2 ALLOT : STANDARDI/O [ OUTPUT ] LITERAL OUTPUT 4 CMOVE ; DEFER 'ABORT ' NOOP IS 'ABORT : ABORT CLEARSTACK END-TRACE 'ABORT STANDARDI/O QUIT ; -2 ALLOT \ (ERROR ABORT" ERROR" 20MAR85BP) VARIABLE SCR 1 SCR ! VARIABLE R# 0 R# ! : (ERROR ( STRING -- ) STANDARDI/O SPACE HERE .NAME COUNT TYPE SPACE ?CR BLK @ ?DUP IF SCR ! >IN @ R# ! THEN QUIT ; -2 ALLOT ' (ERROR ERRORHANDLER ! : (ABORT" "LIT SWAP IF >R CLEARSTACK R> ERRORHANDLER PERFORM EXIT THEN DROP ; RESTRICT \ | : (ERR" "LIT SWAP IF ERRORHANDLER PERFORM EXIT THEN DROP ; RESTRICT : ABORT" COMPILE (ABORT" ," ; IMMEDIATE RESTRICT : ERROR" COMPILE (ERR" ," ; IMMEDIATE RESTRICT \ -TRAILING 08APR85BP) 020 CONSTANT BL CODE -TRAILING ( ADDR N1 -- ADR N2 ) TYA SETUP JSR SP X) LDA N 2+ STA CLC SP )Y LDA N 1+ ADC N 3 + STA N LDY CLC CS ?[ LABEL (-TRAIL DEY N 2+ )Y LDA BL # CMP 0<> ?[ INY 0= ?[ N 1+ INC ]? TYA PHA N 1+ LDA PUSH JMP ]? ]? TYA (-TRAIL BNE N 3 + DEC N 1 + DEC (-TRAIL BPL TYA PUSH0A JMP END-CODE \ SPACE SPACES 29JAN85KS/BP) : SPACE BL EMIT ; : SPACES ( U --) 0 ?DO SPACE LOOP ; \\ : -TRAILING ( ADDR N1 -- ADDR N2) 2DUP BOUNDS ?DO 2DUP + 1- C@ BL - IF LEAVE THEN 1- LOOP ; \ HOLD <# #> SIGN # #S 24DEC83KS) | : HLD ( -- ADDR) PAD 2- ; : HOLD ( CHAR -- ) -1 HLD +! HLD @ C! ; : <# HLD HLD ! ; : #> ( 32B -- ADDR +N ) 2DROP HLD @ HLD OVER - ; : SIGN ( N -- ) 0< IF ASCII - HOLD THEN ; : # ( +D1 -- +D2) BASE @ UD/MOD ROT 09 OVER < IF [ ASCII A ASCII 9 - 1- ] LITERAL + THEN ASCII 0 + HOLD ; : #S ( +D -- 0 0 ) BEGIN # 2DUP D0= UNTIL ; \ PRINT NUMBERS 24DEC83KS) : D.R -ROT UNDER DABS <# #S ROT SIGN #> ROT OVER MAX OVER - SPACES TYPE ; : .R SWAP EXTEND ROT D.R ; : U.R 0 SWAP D.R ; : D. 0 D.R SPACE ; : . EXTEND D. ; : U. 0 D. ; \ .S LIST C/L L/S 24DEC83KS) : .S SP@ S0 @ OVER - 020 UMIN BOUNDS ?DO I @ U. 2 +LOOP ; 40 CONSTANT C/L \ SCREEN LINE LENGTH 10 CONSTANT L/S \ LINES PER SCREEN : LIST ( BLK --) SCR ! ." SCR " SCR @ DUP U. ." DR " DRV? . L/S 0 DO CR I 2 .R SPACE SCR @ BLOCK I C/L * + C/L -TRAILING TYPE LOOP CR ; \ MULTITASKER PRIMITIVES BP03NOV85) CODE PAUSE NEXT HERE 2- ! END-CODE : LOCK ( ADDR --) DUP @ UP@ = IF DROP EXIT THEN BEGIN DUP @ WHILE PAUSE REPEAT UP@ SWAP ! ; : UNLOCK ( ADDR --) DUP LOCK OFF ; LABEL WAKE WAKE >WAKE ! PLA SEC 5 # SBC UP STA PLA 0 # SBC UP 1+ STA 04C # LDA UP X) STA 6 # LDY UP )Y LDA SP STA INY UP )Y LDA SP 1+ STA 1 # LDY SP X) LDA RP STA SP )Y LDA RP 1+ STA SP 2INC IP # LDX XPULL JMP END-CODE \ BUFFER MECHANISM 15DEC83KS) cas 26jan06 USER FILE 0 FILE ! \ ADR OF FILE CONTROL BLOCK VARIABLE PREV 0 PREV ! \ LISTHEAD | VARIABLE BUFFERS 0 BUFFERS ! \ SEMAPHOR 0408 CONSTANT B/BUF \ size of buffer \\ structure of buffer (same for all volksFORTH ) cas 26jan06 0 : LINK 2 : FILE 6 : BLOCKNR 8 : STATUSFLAGS 0A : DATA .. 1 KB .. STATUSFLAG BITS: 15 1 -> UPDATED FILE = -1 EMPTY BUFFER = 0 NO FCB , DIRECT ACCESS = ELSE ADR OF FCB ( SYSTEM DEPENDENT ) \ SEARCH FOR BLOCKS IN MEMORY 11JUN85BP) LABEL THISBUFFER? 2 # LDY [[ N 4 + )Y LDA N 2- ,Y CMP 0= ?[[ INY 6 # CPY 0= ?] ]? RTS \ ZERO IF THIS BUFFER ) | CODE (CORE? ( BLK FILE -- ADDR / BLK FILE ) \ N-AREA : 0 BLK 2 FILE 4 BUFFER \ 6 PREDECESSOR 3 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] USER' OFFSET # LDY CLC UP )Y LDA N 2+ ADC N 2+ STA INY UP )Y LDA N 3 + ADC N 3 + STA PREV LDA N 4 + STA PREV 1+ LDA N 5 + STA THISBUFFER? JSR 0= ?[ \ " 11JUN85BP) LABEL BLOCKFOUND SP 2INC 1 # LDY 8 # LDA CLC N 4 + ADC SP X) STA N 5 + LDA 0 # ADC SP )Y STA ' EXIT @ JMP ]? [[ N 4 + LDA N 6 + STA N 5 + LDA N 7 + STA N 6 + X) LDA N 4 + STA 1 # LDY N 6 + )Y LDA N 5 + STA N 4 + ORA 0= ?[ ( LIST EMPTY ) NEXT JMP ]? THISBUFFER? JSR 0= ?] \ FOUND, RELINK N 4 + X) LDA N 6 + X) STA 1 # LDY N 4 + )Y LDA N 6 + )Y STA PREV LDA N 4 + X) STA PREV 1+ LDA N 4 + )Y STA N 4 + LDA PREV STA N 5 + LDA PREV 1+ STA BLOCKFOUND JMP END-CODE \\ (CORE? 23SEP85BP | : this? ( blk file bufadr -- flag ) DUP 4+ @ SWAP 2+ @ D= ; | : (CORE? ( BLK FILE -- DATAADDR / BLK FILE ) BEGIN OVER OFFSET @ + OVER PREV @ THIS? IF RDROP 2DROP PREV @ 8 + EXIT THEN 2DUP >R OFFSET @ + >R PREV @ BEGIN DUP @ ?DUP 0= IF RDROP RDROP DROP EXIT THEN DUP R> R> 2DUP >R >R ROT THIS? 0= WHILE NIP REPEAT DUP @ ROT ! PREV @ OVER ! PREV ! RDROP RDROP REPEAT ; -2 ALLOT \ (DISKERR 11JUN85BP) : (DISKERR ." ERROR ! R TO RETRY " KEY DUP ASCII R = SWAP ASCII R = OR NOT ABORT" ABORTED" ; DEFER DISKERR ' (DISKERR IS DISKERR DEFER R/W \ BACKUP EMPTYBUF READBLK 11JUN85BP) | : BACKUP ( BUFADDR --) DUP 6+ @ 0< IF 2+ DUP @ 1+ \ BUFFER EMPTY IF FILE = -1 IF INPUT PUSH OUTPUT PUSH STANDARDI/O BEGIN DUP 6+ OVER 2+ @ 2 PICK @ 0 R/W WHILE ." WRITE " DISKERR REPEAT THEN 080 OVER 4+ 1+ CTOGGLE THEN DROP ; | : EMPTYBUF ( BUFADDR --) 2+ DUP ON 4+ OFF ; | : READBLK ( BLK FILE ADDR -- BLK FILE ADDR) DUP EMPTYBUF INPUT PUSH OUTPUT PUSH STANDARDI/O >R BEGIN OVER OFFSET @ + OVER R@ 8 + -ROT 1 R/W WHILE ." READ " DISKERR REPEAT R> ; \ TAKE MARK UPDATES? FULL? CORE? BP) | : TAKE ( -- BUFADDR) PREV BEGIN DUP @ WHILE @ DUP 2+ @ -1 = UNTIL BUFFERS LOCK DUP BACKUP ; | : MARK ( BLK FILE BUFADDR -- BLK FILE ) 2+ >R 2DUP R@ ! OFFSET @ + R@ 2+ ! R> 4+ OFF BUFFERS UNLOCK ; | : UPDATES? ( -- BUFADDR / FLAG) PREV BEGIN @ DUP WHILE DUP 6+ @ 0< UNTIL ; | : FULL? ( -- FLAG) PREV BEGIN @ DUP @ 0= UNTIL 6+ @ 0< ; : CORE? ( BLK FILE -- ADDR /FALSE) (CORE? 2DROP FALSE ; \ BLOCK & BUFFER MANIPULATION 11JUN85BP) : (BUFFER ( BLK FILE -- ADDR) BEGIN (CORE? TAKE MARK REPEAT ; -2 ALLOT : (BLOCK ( BLK FILE -- ADDR) BEGIN (CORE? TAKE READBLK MARK REPEAT ; -2 ALLOT | CODE FILE@ ( -- N ) USER' FILE # LDY UP )Y LDA PHA INY UP )Y LDA PUSH JMP END-CODE : BUFFER ( BLK -- ADDR ) FILE@ (BUFFER ; : BLOCK ( BLK -- ADDR ) FILE@ (BLOCK ; \ BLOCK & BUFFER MANIPULATION 09SEP84KS) : UPDATE 080 PREV @ 6+ 1+ C! ; : SAVE-BUFFERS BUFFERS LOCK BEGIN UPDATES? ?DUP WHILE BACKUP REPEAT BUFFERS UNLOCK ; : EMPTY-BUFFERS BUFFERS LOCK PREV BEGIN @ ?DUP WHILE DUP EMPTYBUF REPEAT BUFFERS UNLOCK ; : FLUSH SAVE-BUFFERS EMPTY-BUFFERS ; \ MOVING BLOCKS 15DEC83KS) cas 26jan06| : (COPY ( FROM TO --) DUP FILE@ CORE? IF PREV @ EMPTYBUF THEN FULL? IF SAVE-BUFFERS THEN OFFSET @ + SWAP BLOCK 2- 2- ! UPDATE ; | : BLKMOVE ( FROM TO QUAN --) SAVE-BUFFERS >R OVER R@ + OVER U> >R 2DUP U< R> AND IF R@ R@ D+ R> 0 ?DO -1 -2 D+ 2DUP (COPY LOOP ELSE R> 0 ?DO 2DUP (COPY 1 1 D+ LOOP THEN SAVE-BUFFERS 2DROP ; : COPY ( FROM TO --) 1 BLKMOVE ; : CONVEY ( [BLK1 BLK2] [TO.BLK --) SWAP 1+ 2 PICK - DUP 0> NOT ABORT" NO!!" BLKMOVE ; \ ALLOCATING BUFFERS 23SEP83KS) 12jan13py F000 CONSTANT LIMIT VARIABLE FIRST : ALLOTBUFFER ( -- ) FIRST @ R0 @ - B/BUF 2+ U< ?EXIT B/BUF NEGATE FIRST +! FIRST @ DUP EMPTYBUF PREV @ OVER ! PREV ! ; : FREEBUFFER ( -- ) FIRST @ LIMIT B/BUF - U< IF SAVE-BUFFERS BEGIN DUP @ FIRST @ - WHILE @ REPEAT FIRST @ @ SWAP ! B/BUF FIRST +! THEN ; : ALL-BUFFERS BEGIN FIRST @ ALLOTBUFFER FIRST @ = UNTIL ; \ ENDPOINTS OF FORGET 04JAN85BP/KS) | : \? ( NFA -- FLAG ) C@ 020 AND ; | : FORGET? ( ADR NFA -- FLAG ) \ CODE IN HEAP OR ABOVE ADR ? NAME> UNDER 1+ U< SWAP HEAP? OR ; | : ENDPOINTS ( ADDR -- ADDR SYMB) HEAP VOC-LINK @ >R BEGIN R> @ ?DUP \ THROUGH ALL VOCABS WHILE DUP >R 4 - >R \ LINK ON RETURNST. BEGIN R> @ >R OVER 1- DUP R@ U< \ UNTIL LINK OR SWAP R@ 2+ NAME> U< AND \ CODE UNDER ADR WHILE R@ HEAP? [ 2DUP ] UNTIL \ SEARCH FOR A NAME IN HEAP R@ 2+ \? IF OVER R@ 2+ FORGET? IF R@ 2+ (NAME> 2+ UMAX THEN \ THEN UPDATE SYMB THEN REPEAT RDROP REPEAT ; \ REMOVE 23JUL85WE | CODE REMOVE ( DIC SYMB THR - DIC SYMB) 5 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] USER' S0 # LDY CLC UP )Y LDA 6 # ADC N 6 + STA INY UP )Y LDA 0 # ADC N 7 + STA 1 # LDY [[ N X) LDA N 8 + STA N )Y LDA N 9 + STA N 8 + ORA 0<> ?[[ N 8 + LDA N 6 + CMP N 9 + LDA N 7 + SBC CS ?[ N 8 + LDA N 2 + CMP N 9 + LDA N 3 + SBC ][ N 4 + LDA N 8 + CMP N 5 + LDA N 9 + SBC ]? CC ?[ N 8 + X) LDA N X) STA N 8 + )Y LDA N )Y STA ][ N 8 + LDA N STA N 9 + LDA N 1+ STA ]? ]]? (DROP JMP END-CODE \ REMOVE- FORGET-WORDS 29APR85BP) | : REMOVE-WORDS ( DIC SYMB -- DIC SYMB) VOC-LINK BEGIN @ ?DUP WHILE DUP >R 4 - REMOVE R> REPEAT ; | : REMOVE-TASKS ( DIC --) UP@ BEGIN 1+ DUP @ UP@ - WHILE 2DUP @ SWAP HERE UWITHIN IF DUP @ 1+ @ OVER ! 1- ELSE @ THEN REPEAT 2DROP ; | : REMOVE-VOCS ( DIC SYMB -- DIC SYMB) VOC-LINK REMOVE THRU.VOCSTACK DO 2DUP I @ -ROT UWITHIN IF [ ' FORTH 2+ ] LITERAL I ! THEN -2 +LOOP 2DUP CURRENT @ -ROT UWITHIN IF [ ' FORTH 2+ ] LITERAL CURRENT ! THEN ; \ FORGET-WORDS cas 26jan06 | : FORGET-WORDS ( DIC SYMB --) OVER REMOVE-TASKS REMOVE-VOCS REMOVE-WORDS HEAP SWAP - HALLOT DP ! 0 LAST ! ; \ DELETING WORDS FROM DICT. 13JAN83KS) : CLEAR HERE DUP UP@ FORGET-WORDS DP ! ; : (FORGET ( ADR --) DUP HEAP? ABORT" IS SYMBOL" ENDPOINTS FORGET-WORDS ; : FORGET ' DUP [ DP ] LITERAL @ U< ABORT" PROTECTED" >NAME DUP HEAP? IF NAME> ELSE 2- 2- THEN (FORGET ; : EMPTY [ DP ] LITERAL @ UP@ FORGET-WORDS [ UDP ] LITERAL @ UDP ! ; \ SAVE BYE STOP? ?CR 20OCT84KS/BP) : SAVE HERE UP@ FORGET-WORDS VOC-LINK @ BEGIN DUP 2- 2- @ OVER 2- ! @ ?DUP 0= UNTIL UP@ ORIGIN 0100 CMOVE ; : BYE FLUSH EMPTY (BYE ; | : END? KEY #CR (C 3 ) = IF TRUE RDROP THEN ; : STOP? ( -- FLAG) KEY? IF END? END? THEN FALSE ; : ?CR COL C/L 0A - U> IF CR THEN ; \ IN/OUTPUT STRUCTURE 02MAR85BP) | : OUT: CREATE DUP C, 2+ DOES> C@ OUTPUT @ + PERFORM ; : OUTPUT: CREATE ] DOES> OUTPUT ! ; 0 OUT: EMIT OUT: CR OUT: TYPE OUT: DEL OUT: PAGE OUT: AT OUT: AT? DROP : ROW ( -- ROW) AT? DROP ; : COL ( -- COL) AT? NIP ; | : IN: CREATE DUP C, 2+ DOES> C@ INPUT @ + PERFORM ; : INPUT: CREATE ] DOES> INPUT ! ; 0 IN: KEY IN: KEY? IN: DECODE IN: EXPECT DROP \ ALIAS ONLY DEFINITIONEN 29JAN85BP) ONLY DEFINITIONS FORTH : SEAL 0 ['] ONLY >BODY ! ; \ KILL ALL WORDS IN ONLY) ' ONLY ALIAS ONLY ' FORTH ALIAS FORTH ' WORDS ALIAS WORDS ' ALSO ALIAS ALSO ' DEFINITIONS ALIAS DEFINITIONS HOST TARGET \ 'COLD 07JUN85BP) cas 02aug2020| : INIT-VOCABULARYS VOC-LINK @ BEGIN DUP 2- @ OVER 4 - ! @ ?DUP 0= UNTIL ; | : INIT-BUFFERS 0 PREV ! LIMIT FIRST ! ALL-BUFFERS ; DEFER 'COLD ' NOOP IS 'COLD | : (COLD INIT-VOCABULARYS INIT-BUFFERS PAGE 'COLD ONLYFORTH ." volksFORTH-83 3.8.1 py65 202008" CR RESTART ; -2 ALLOT DEFER 'RESTART ' NOOP IS 'RESTART | : (RESTART ['] (QUIT IS 'QUIT DRVINIT 'RESTART [ ERRORHANDLER ] LITERAL @ ERRORHANDLER ! ['] NOOP IS 'ABORT ABORT ; -2 ALLOT \ COLD BOOTSYSTEM RESTART 09JUL85WE) CODE COLD HERE >COLD ! ' (COLD >BODY 100 U/MOD # LDA PHA # LDA PHA LABEL BOOTSYSTEM CLI 0 # LDY CLC S0 LDA 6 # ADC N STA S0 1+ LDA 0 # ADC N 1+ STA [[ ORIGIN ,Y LDA N )Y STA INY 0= ?] LABEL WARMBOOT BOOTNEXTLEN 1- # LDY [[ BOOTNEXT ,Y LDA PUTA ,Y STA DEY 0< ?] CLC S0 LDA 6 # ADC UP STA S0 1+ LDA 0 # ADC UP 1+ STA USER' S0 # LDY UP )Y LDA SP STA INY UP )Y LDA SP 1+ STA USER' R0 # LDY UP )Y LDA RP STA INY UP )Y LDA RP 1+ STA 0 # LDX 1 # LDY TXA RP X) STA RP )Y STA PLA IP STA PLA IP 1+ STA LABEL XYNEXT 0 # LDX 1 # LDY NEXT JMP END-CODE \ ( RESTART PARAM.-PASSING TO FORTH BP) CODE RESTART HERE >RESTART ! ' (RESTART >BODY 100 U/MOD # LDA PHA # LDA PHA WARMBOOT JMP END-CODE \ CODE FOR PARAMETER-PASSING TO FORTH cas 26jan06 \ Include system dependent Input / Output code \ (Keyboard and Screen) include systemio.fb HOST ' TRANSIENT 8 + @ TRANSIENT FORTH CONTEXT @ 6 + ! TARGET FORTH ALSO DEFINITIONS : FORTH-83 ; \ LAST WORD IN DICTIONARY \ SYSTEM DEPENDENT CONSTANTS BP/KS) VOCABULARY ASSEMBLER ASSEMBLER DEFINITIONS TRANSIENT ASSEMBLER PUSHA CONSTANT PUSHA \ PUT A SIGN-EXTENDED ON STACK PUSH0A CONSTANT PUSH0A \ PUT A ON STACK PUSH CONSTANT PUSH \ MSB IN A AND LSB ON JSR-STACK RP CONSTANT RP UP CONSTANT UP SP CONSTANT SP IP CONSTANT IP N CONSTANT N PUTA CONSTANT PUTA W CONSTANT W SETUP CONSTANT SETUP \ NEXT CONSTANT NEXT XYNEXT CONSTANT XYNEXT (2DROP CONSTANT POPTWO (DROP CONSTANT POP \ SYSTEM PATCHUP 05JAN85BP) cas 26jan06 FORTH DEFINITIONS \ change memory layout for stacks and buffers here 6000 ' LIMIT >BODY ! $5800 S0 ! $5B00 R0 ! S0 @ DUP S0 2- ! 6 + S0 7 - ! HERE DP ! HOST TUDP @ TARGET UDP ! HOST TVOC-LINK @ TARGET VOC-LINK ! HOST MOVE-THREADS \ No newline at end of file diff --git a/6502/py65/6502f83.fth b/6502/py65/6502f83.fth index 07c9fdc..1eda541 100644 --- a/6502/py65/6502f83.fth +++ b/6502/py65/6502f83.fth @@ -20,7 +20,7 @@ ende 123 \ *** Block No. 1, Hexblock 1 -\ volksFORTH Loadscreen for py65 target cas 15juli2020 +\ volksFORTH Loadscreen for py65 target cas 02aug2020 forth definitions : (C [compile] ( ; IMMEDIATE \ : ) ; IMMEDIATE @@ -58,7 +58,7 @@ HERE DUP ORIGIN! \ *** Block No. 3, Hexblock 3 -\ Coldstartvalues and user variables cas 15juli2020 +\ Coldstartvalues and user variables cas 02aug2020 \ 0 JMP 0 JSR HERE 2- >LABEL >WAKE @@ -67,7 +67,7 @@ HERE DUP ORIGIN! 0D6 ALLOT \ Bootlabel -," VOLKSFORTH-83 3.8 py65 15july2020 CS" +," VolksForth-83 3.8.1 py65 02aug2020 CS" @@ -172,7 +172,7 @@ USER UDP \ POINTS TO NEXT FREE ADDR IN USER \ *** Block No. 9, Hexblock 9 -\ MANIPULATE SYSTEM POINTERS 29JAN85BP) +\ MANIPULATE SYSTEM POINTERS 29JAN85BP) cas 02aug2020 CODE SP@ ( -- ADDR) SP LDA N STA SP 1+ LDA N 1+ STA @@ -628,12 +628,12 @@ CODE U< ( U1 U2 -- FLAG) \ *** Block No. 33, Hexblock 21 -\ COMPARISION WORDS 24DEC83KS) +\ COMPARISION WORDS 24DEC83KS) cas 02aug2020 | : 0< 8000 AND 0<> ; : > ( N1 N2 -- FLAG) SWAP < ; -: 0> ( N -- FLAG) NEGATE 0< ; +: 0> ( N -- FLAG) DUP 0< SWAP 0= OR NOT ; : 0<> ( N -- FLAG) 0= NOT ; : U> ( U1 U2 -- FLAG) SWAP U< ; : = ( N1 N2 -- FLAG) - 0= ; @@ -2300,7 +2300,7 @@ HOST TARGET \ *** Block No. 121, Hexblock 79 -\ 'COLD 07JUN85BP) cas 15juli2020 +\ 'COLD 07JUN85BP) cas 02aug2020 | : INIT-VOCABULARYS VOC-LINK @ BEGIN DUP 2- @ OVER 4 - ! @ ?DUP 0= UNTIL ; @@ -2309,7 +2309,7 @@ HOST TARGET DEFER 'COLD ' NOOP IS 'COLD | : (COLD INIT-VOCABULARYS INIT-BUFFERS PAGE 'COLD ONLYFORTH - ." volksFORTH-83 3.8 py65 202007" CR RESTART ; -2 ALLOT + ." volksFORTH-83 3.8.1 py65 202008" CR RESTART ; -2 ALLOT DEFER 'RESTART ' NOOP IS 'RESTART | : (RESTART ['] (QUIT IS 'QUIT diff --git a/6502/py65/vfpy65.bin b/6502/py65/vfpy65.bin index 946c79edbee6ae220d3ab41cbc4ba4153219309c..622acefa8c49b18a959705dd4e8a61f03fd368b0 100644 GIT binary patch literal 17587 zcmeHu342@Bwdm4l*%`1koFiMYePmg(ElVEd*_N#{*is@}MneWN6ml^nOaTKUrTK#qBSKZ$}Meqm(qqNsiC*jZD?QGCX_Nnm;g5^4MP*^x7Im!;@sOm z@ZOj3**<&iwb$Nz?KSVsdtrCid*LU$!ur)*StG2*|JFV$0_4Dt`JV)q)}IxM;Q#f1 zu9aJEx%tlSErWM$@;29V^;OMPwcPFZG&XQGb=Tc}V_i*M4aW(whh}Hfo@Cqp+1X^P zHRai?PI?Y#Zke4uZ5H(Tf-T57KHP(eUV6i85rQ^Jbfe@>IwDvDh;^?7|K(} zY7SN!43NxINAWAi0N=<{i~R>H7aQOSMDFg6N%4b~OAW9$Ps;~l(!oj`m&Tq%ygz|G zMg#mLPZ#Qw8)gIiGH7Gr0;i10s2Gj(|K7L+ zG$yUIIuy5>#<-*>%_Y6z-y4_0RVH00fvZhp&OE1K!6wS5e~%L^1*a)XS}h5QxD-R2 zWGk|!Z2?-i1#x;zS^ZM9I}+{9xKEg_HZi8F;AWFr=-NR;cpM^30IrJ1Rb2)5VUK!VG*2Y!^ z`g_c2=hLGa+yTF9#F^rensaI#s6FN!aqdjfmQ3I`Ys5tVUFHP`MuTMRv~#D7bBkHq ziAYc23i6!O8f0$xF0&bSo3*4@2QC|{MV>g7#XAwv0^c=jqLKLT%<@u%Q5DkGj5tSi zw2+j5U#b)`0!JhTTGyydKg7^=I6Yxm9i#S#*g$ zQHl~|QifDnwEZDrMaF%S`J`}(F>N`4>}R0MqK!tvsP=>Aabu5ViE+?;o;hSBq!){c z77ME^x;kPW%{Fd4Ww;6Z+|26oQ6T*Lodn^O$o+wR@h%j6$Ojma*zO zZ-BM#exndtS#3O;kbIT1vxU&j>be8r7`6ZkA;y+?YkS#3xQ?~gti``Kv8q~Mr3$+S zSyi2{QjK3<>#1m9=3 z3*k`wD7!$T#yofuBhFKvY4s^DZng-1!ajgVrxzlnJ;*dfOnJy0d(ciQsBf{qKvXFj zkR^A9h1t`Vpe+Y9_8Im#$Cxzs!|ZANTMSFB>YDaWYucHsnV2ob36aIc(2UTIgq39Q z%)8Sw#n5NXN~{XSgQ32gt@6o@s>Ym0__XsK;Xn?4iTEWQ_({0i%E1?`s`e2ao5b#< zu)unzgsYu3kIjz@2N3t`R&}EN#ear8kA{aXSdnhVjoa9E+ES3unC$Q)tIAKx`wc6# z{tK6j%|Y{Dtdcoqebpi`1peHrscA=e%&N4_`Rar`>IHdJX}+o><90AHxmBO95o@sh zszqrB^3@_Xw=mB#J@S-SBcPp>e6Pj91Z|7qBWtOp)Z((~VUL9mm%zVbJFuGC-;mpT^RNtig%H9}L z3H&Z!D+c&j#{GIe&9wzLS_1FpYZkyZAdJ>>$atP1vqfe}!k=+8Ob+-w|ABHbLbk}k zTvgzJih}Lso%4Xl%|!I7f_8M?6)uybOkHy7qZ=##9C)HbeUY zR0l(PSO#M@eP@3l6h+QD7_okFqA!LPNQft*lE|1|hFpDcVmADiEjR&BFWB}j+UF)Y zlq-iH+jIhklAZcx6Dl;SDgKaiIy)u&hWxHz-4%YrRsk1mFNM(NXzW4TO|~JHF;xJ! z>~K6Np@3=%hS)>4VH*MKmmQYS=4IRj(%4;yEt!XHz4D0QvLn2N(Qd~5gl(G)8CZ5? zRWL+h%QnQ{#wzq@*niC4Zy_ms#x`iCRuf8V4zwaAm+iw@nrQ2?qfx0}3ZR#!p)}QF z%cvv0>`0<79zx5dz=JZ}4X-SFiNsW6uP(UBwhL!>!<)-~E{m?l-gOanZrNcHsEm7; zO!eUcjs4yN+M64)3y;XcHsANt1%0K3$*>flW4srozmuJpf5ub^U4@!NulxE!B@Rjo zQ#-^R(s-_3a)~a%#qVa(d=5xS3BB3Q0Wm4=)}Ip4YV)s5pGcusn@XXFQ$m)MFieii z1M3Ray>3OTNkvKPHlXN`1tUgnz!*bd#*G^b56OL`<{o&qP=#YQ7LrbS;O#m{vJ%)D%q0yEQ#9!|rJXrx=S>tX+=OIn;O!zUZ71U%H@=>K$oLE{pa#wt zsj4$>b#Wx5op_ans<8q~#|hxzI3qe8AuHhAgo5pinz{Zl=s zr0|~NI@npPmy!KHQ?RWmf#it(^dx&u3Hx~KZrx5AwP*U%qtelyqr&tVnNl4*SFELZ zXxDqu{RC|WIAnaWm_f6@8-Lfs*`+DRtwBb_+dn?;dB^DkWE<2-i1cX2WvTPcPJbl;*>q6_@|^ZIV0Uu)8|k1 zyfXdqQ{ovtwqBY3yS&y0xRuier6>}3GLORQ2KY9o=?~zE?c-)x9!O#vV3N}X!eNTq zpUktMgg3xToXSHu=SZL#_n;8z?U!v3xvlf4HYZGETpQst zPV0z=_=6PyjbO2B{YpdC2qkunKh&pmRNFOtc!l!aX4l6019Kfcb`1{5xGU_m>PCp$ zbyp{(=$efC8jPd*p}4aTdzRVHnHubAHh@2jsR^z}5<&oND2hhsxZ?==LHmCRxn(UO9eb8)A3I~>qIUj1W zr=1Tq+ruB0jA~Q7PB_ysCZadWJ0+r7lu|qvQ-q^@_=%E~h{i`s_E5Ls^4{_@hEqWr zJpE?#s5&K{C9+c~3I8_RtrOb$tYUO=8h1tptAu=FQrMXaj_~R3siVQ%PbRn#Ok&aE zc7VG?AB!ZSqz?f+HHvf$U~YMhXH3`Fm&qsG0d|LWRV0dn>2_RG!k9Xs+o9_ZL`n9? zjc!K+qW#rAX_hd_8?lcY$=?s+cR{{`X|R*fcEBo!wlC0&1NPSUI+~COWAek-9J*K> z^C%KBKRoG>0x=;JQgBW(+f7e7PROC76~jnBJmXM%N+{kffiE~HsyNBK!WE!I`{6$w z+e@NfJekyB)Vxm0}8_g_}zW_t8>KP{LSvhRuZ^=PBc#EzJ@o zA=FDr%M6Q!OBvn;KQGmbSYwNK61WD4=UstXFkXe4vHb zF&`7*H!f{B5R22QGw#puL>|XIi11gJHW(7|kUw|P5<1xvCXeTYi9}3<>@s~+S}Bo) zQFjh@U+Q#~y^LkwL^Kv6w_06B=b#XwlH9A7Ni4}x=p}+smL2NtmBf%NO*3p4BoJGK zTgwa>;-hsIP;_S4Z8BJbWLb`Y!DSRpfUx5GWuu04NfK)?B}tcTnbll1Jmqc!QJDr{?T z*FYQQA!K=o*<0MSf^NtzKO#n?7^c-4`=;_4HVmgZjlH9sm`8d#3#Tpgy9rGs!N}uZ zf(32MU=X9;lZ>*!lgx|7Lo6*zaqm6w#d2LI?nk6!?t$aws;^|+Zi&Rnp-e^pfFW;9NaH#@x$avb zmc}xtNInjoA?492jMvmj9;-dV7$0n|C?4RI)}{*XOir2)qA%w+Vd;fG(mj13B^>FQ zemeX)vm9D0bbiG-eS-2r(aAE{Yk8Cv&>dB$Td4-!I#)kf0rpD6 z%0M&};3>HkDwGH`3|Cj`6LYFMXjWsSnU=-7B44aul89lPjH1MKC&FRslMsU}YZx|F zYN=PDbVuds|2eyL0K=GFQv;5<6@=kCl^76*0x=pyqC2>N+l$c#|6}$Qj`*es*(zBf zd*N86dSyT9!R7yYA={IM#w{xK$tJTGO0XU2i(`Q)<6i1f@?APIYMp1=J&dUr>O5Mk zfMV9Y6i~HsQ!4GwzQ(Z+g~yn!SuE0=eErqSPJg3&k-r#?{fn zJ@S(2I;WHMy2spv=l1F_6r?j-?x`+V3NrgCo(UKblEHo5Y4JBb)4$v~{mG~XLtea{>A_z(La<&{ zg?2@*zEV_QQQSOlAW~ulhovDbvZsV_Th$nT(3R2xMM#Ocs;QhB-Ja0w_ons?&y|Je zWHJs$hd2vlaij=Ekmq z8>$0qNv(#e6E*eKPdO;@Tm>IgtB^%A?6Y&w?;w=!9gw{O=I=qqv>G%uIuw4z5Y4b` z4Vgi*eL>_@vJEf0kyS1DcA%_AQy#+2U&^RSr%6FDVXvkDTZt!Y@tYz_**795Ihnd# zyIc*C8lGtUplZ-OP&49Ik{r5(NZ`DT9Fk?+ZFOY7K0+Z_6c6l=Ex}W`!x&*^=q(Q59CE zepJJlDE2x+vDZ5od&xy<>>z@R6iX)c_Q%&;1De{bDg?w6v9_AQyn_{#Z4m>mfxg=9 z{fStRI78(+sx^!o*VQUX*fp@JRvV5`W#e&-SiPozeM@aXt`BUfr5eHN+QDiJ%i+OV z9abU6X_PS$GU!DxcA4#`|yfU$qU!?h2ixuMR(IOMICJXt83T$Z?O+nuc)K+XdT>Erz@kLwwj^3b+EHe ztDw=`j~dTb??&J^>xkKXVjwDps?oR1um!nC^B!fXY_$%)U#Bk%@M!Rf^XuT{I-T6g zxF^aQ@_t+QeBHO}*2D2SO-#Vo87f#0AJ(a(4sv+w;qP_&a{0AH#{GQVx%z$F7=|yK z{pad0bj;`cOW|*IRIfQlT7PtYpvErNQ>MKE?y5g3FG0?&H^{&*z}M>4eAriscVqBmeKtKl3E}IFo*&ik z!5SgjYLP0)LQbGorrr*QzpOE|Z9xUcx3lsG^tWr@a zV{d&7vw64{KB(8rAk??DY*&E+!(BykQ2)42v;@}y__V=D7-g=P&G%W%`Mwh-ss&yL z4xhT+k#Xny@_i)a*Fn2a?Lb-DVbTyg!ts<( z-(Gx7PR=LsW=_G$!tx%a?P-gGdoR+)MGpJ+T6)mzeTvE6Mwswv#47Z(W=o^xzw!gV zNgt+{z9{~lG*9Hy{MkM#Kx~8;eQH9K%&%kV>oCp^8{u7_CP6?d(-LSST=1#IDgqq# zQ9QX3mNuxc{d&Hsfm+24>V(`)&3^%JgSrZrq-X(6Mi%Lp`8O7H$!`CIsjgugOKzW# z+Z!}OHJ)V`{0nSu(1fdFzRFzuzPmvi#;hXaCi!xfVhu3L{jH9|fw~4%95KrI1V_V{ z8`iSb1*NdwKZ8NU2e>-IF}KVVP$ea8+0yV_{boO%+!xlZV{~1scyJ`urb-a|IWr_54WRnx^Tgy zqpAsmb)Xw#lpgt_-)c&ACxfY;WN0jiL6RyRO!nxyNUW@az}G|L*w**PxC#UmU>1L#IR@l(DU#Y~k7 zCG=NuYgw|6({0>MP}Gz)N2aZ&qUk2Mp-B_1Ue#7JDbT5yF%}}#SOIkLN+q43tsahH z5#=cUJYPo`lNb+DpxlG8(pvT_O+g!(S^cUgUe|NCH@R$onx(=4hED8BW@^s(5V`NL zOIbQWn&?kWmxxjo@)^{;G!_R=V|4~!lVLe{NG6?&q;;5(h%)8lvsB;8xNmP%1jdLN z8-=Gz9VlpfZ}zUn_ZkMx+nNZA>gandr_t>x)K8=5IER-Dw2HeL3mX+mM1c(ErOngr z9?d~LR3!`AKAu$=!1+Zqx{HG$zzQb&5>ponuS~8 zKbrOBydu5?o@t_vk7wU+9$l6$!GNU%4dbnFtXV%l_`T*M&5Y?*_^eqsH}1XW69~Bt z7PsgV{o-7;W*gAz%*bCdf44zV%i9AW1m8~%j&f4zu*LyN9EEQbrrTZUSQF@xs!nxAbZZKY9vYI+F2wXnQJVX|a4 zw{)_d>^W1JjJ>>tj+bu1sG_Od^c*r$lvxU=ji-%NvLthF#DXB@CeJc^El;(O`Ec2+ zcppT4xtQWV)iT5mvClHpv%G~8{4Ma!7OfEJ$2@(AeGMnu0(Gr=x$cP|x}+c(rCO^x zpMpDl@@Tgc-t8c?>cXMkP#oXITzfm*+^Xxw>uWiwydCaoT_k76^G7n=ihduZ)4|-| zc%FFyL!$c|H!#Dk7Blq_yNC^wXs~W?B%^gZJlLAk9hIbo1nz9TztMq%gSK+y6p0lL zrVAAViZER$Q=0;qb4Z?u6QP&orCd5G!g;Kfev{?=t1PDT|Mi(kS@gRaP+lapr`MRncC5O1WkK2sAH{X%^eJwY%D> zMCo9TmQmGgEmi|bFzyCpn@+BxQkibh95KGsPW{yLW_wmSCi*=RdS5CpiS^l`7#Ca9 z%SXb|wwKxo=R&)F9)r z4ZjA*J=rqQaTM>OkdJ;_K=JLp^1b&E{I~;ek0Mmk)pU~2pX!+Epe%X_PIPEG1$1c# z{978RJmZkFZ7qfuL`kSX+2qbMa)D&K>8R`_?#A_Qg^xS3lo!Wxl`X4AMmZ|;b1PK) zwG!%gksr1~*sm6%MSk^GSnb!w*Yrz8e(hG+=+}r+xX7>H3b*;S{ed0?8@9qdesutc z@4_=X=JbFM;z@26O0EBu>ZBSf$O|CnDXF#fky9$T==r~P{QCG^5Y z9-CX_@BEq-(wf7x#8S(&24ug3a_dT6YbZ+xM*SXB= zEaiseC+<}5q9^VP-?-EB_L}DP{%>{N1N%D-WpvXJP|_s17EqU{d8DpS_^fk=Ekeo6 zAfIN~!MsGxYjtnbeF;A7L~|b&-CYx%!HNF}t{w&J{@h%&F#P_!T(mI4^M>3Jero#D zQQPy2@}4Ngx0|2LVU#Esj)fN&IT$!{Xq%FDde*sX7$0qIN_sXWz0|}q?3cmbl{L4- zC*?V3gW=^}YIvke-`GIM^@Fbc+A|N$W@AR9hKVjcsxN|H>DoUB`e~OA>y?qd6J1D7 z4ZrQuQ?tAKeWm@EE}cv#b2C@ShhY_nQD-qpQxK$)+INSJ@9b_(cFYN1e3gA@&aei}}|9#-xL{ z0@}s~G6S~2`vD*R{2_pbIzaccCj;*m{vkj%N(UDL$T3t~+U5I!bM^F_j4~0Teg}{A zNtZM3KLjY$)PcYwWqP880Rd7f#yJ3Qu6@%$W4Bg(#7+$hawq z!eVs+*5~B3hB0NqLp(*%_&8-v!2fnY#{J|h2Zu61>m%WLM%#T zv%x6f%lDPIcqQt3n>V8^&IYfLgkCDWdu!Vh(&&(3WGyKnxY@vu@kM-LUzV0dhGT1@fm~7s#%E1->g7WIKd5 zfLL-byeeb|Vlk-~ZzG~q2v3QhdG1AnrlVq1z*qTu+r4m3&{L}hn{QxKBWkJXt9%O^ zMo}H@rvk*iP%Nqw_*sIVZc!b>PbYphi0Tl2dhoMLRN?>6!sFKpA`wS=rPxS_s#U(q zR{Yv1>hS+!AtDbkUxiylZ6DT4eU)YKRrr#qU%f_Yey!`P@Sv#gkMze^MSPW$rmw;` zMGZE6m0OILUrt||G@n{%@5dn?X}n5d+qhTPcB4DIxa-_c0~1Scxw}^!T)YLC;{Zb3&P=`w*Gx_ z3H(q0SGg({?M`&Y;>obLxt_1DY32tXY-;4|8n@hc*Mt6Ae=RR2o}8T>_oS8`nw?Fx zS~8x^>XhfO=C0Y<^WMXk^~izTP_N`o#)D$0v2Y}lsvGg7{3DxF^&{$3L(~B|;3&+A zhs4;bP<*6%Q>t}SYFVarQhj3CiPmV=l>;jZwY{-ep92iAxlkXAN4g@tZnvSp0NV=H ziP{mj!2pjGs^i$oGr*IDYN>C;z1RTXK;+KOL?}7p&Nsktp;ibcLL+XRH-;nq$-aIZ zF&f~=O;8dYuRZR3oBfZ@tZi@jf6l(fujpAIm zQm9Gvb=+Xg*i%BLDkUBiGWOho1NYZ0t6 zYT|tzDdRyNXDxz~xqdMMkaUmvQ4fA-S8{mCoDlWxieQz6Y z02QMRt%)Sf%rKwwjPogP^lf84+`#DC3G8Kt?S*#3fcT4L8$qY>&@ZDMt> zFT{@9pHFM>1j3$u_Kbkk>=Orp`os2p_Mr?NiGk&;M(XeT9J}DcXp)RQZXc3ywy@fE zMEVBqpwK?4LFPt3$FlGhR!e&IgHO%XB2Vnf=Iw}Rf()yP$CAHd<*kTm71Gx1v!`{m zk&K8fRR$S>Gg2b$D=iaH25`O^-e9#}B#?ETWKXgzV}?a0O>d+x>k`>!xnE+^_4i7l zI6+2bh{vSui-_G>*BSGFmM$`mnNB17%@8nY*fckArJoEq*)V-8_YPka(<8+I9LQ=R(UJT z$g$?%AxP%+2QpLT(NeRfHK z4U)W}4Ivb5`vzer-tM@41Ku)jp#;8fR@b?IYaUTqZnYoQplG3Cuy027l1ERO)qeNK zNNe)l68O-pu6G-_5zXYU^0^W1 z+d0eLcT1s}(w{W)F0sOm(Q`NcMDjXW* zRDQQxjjhjfs(QCugRMt7RfF5D#nx9ib*wk*>gGiD63SF5?B_J-2ePh#Imi+i;T{#E zk>oLMfkq8`@Fw=z&wD1-=e>B?CGcbJ5k#6^h&1j&rXga+L+03nc2Yt89rr4thT=h4 za;G?$oi+umd2ofF;@;v}<_iBa?mhfl28%7~+U0GQaeIMgWVR9)L>8Ap6GGb(7Lvi4 zKTJ-SLDZ7dzdDi(M|w9~Q+;c!Y^ zU_CS9N_*{7^YfzZh`ZaO?qB|se}p`bhL;|+Alk=z3?Ep^P35K%s~(;<5yh-4mkC(4pct2OSW~3wiQtV7 zn?A5SSX2(Xu^(JR{U_!AH;c6WbATfuh3pQUsT|%Y(n>)g zk#)UYL~CuugOx+JNV5R87GboPqsGf-GFN1dMEpskL8^dDMUOb87}+43Syx;EWyOy= z+vfpKu|!l?d=%~5X=conHj-_t0AI0Qh@qv#bw}ATlPCj|#gF6Gq8I|*S3IJRo-$U# z=Hir-0FM=0MpU=*JNdnf#(C6I9@WhOXt>b>58*FQT7~^e_+s&6PB%^XQ8C^xPBYNN{+7%M<`s` zf%rQ(h5i)x$?U@>lEQ=5L6&-6l-4|GMoJ~t|D2_Tww9cThx$T6^v*PumU^Ou2L7ew zczPzdt5h_DgjVRoOn!n zEOf9yAF7h7#42Gghjw#AC>26CHnc%XNqhC@MKssK>y!VHL3cKhLD#0lDj9Jnc`Oek zO4U6sMXgCkN$u96?2wuhr`BR{5j3Zb1EojhG17AnJXfm1IRmAnlpZ)!s`k5PN{8)v zCTbq|+FI ziEJ5{iyqSl2bQS)zW0`l+w;clTPRG}f@Evq%n~gfC+kWZ-!3|8{4Q>w7XG|Mq>uFrVef{(}_LE?%ic08dS!iW5Q(a39&#YTfFhkebU6_|2f}vJ{0|G znIFDXrk9ZeKT@zQ8Ik0O{&c0f&Wqm@EPHiBG;9Cl-%f;1be#|*Ogt1*>Jhm~e8Gl%2Dcpo4#2^~UH0~x~ErwBc7c*_7pdla1P?FA| zqL*0TpCzGQ3OfpQ^TDe0$8wqQ3M)+fmjS{jy`fMrj@D0QECu?lu_9uO| z=(+N=HY4c7nYLjG-BICr3C&_CBVZLpJRwB)mS-e1KA}_>4I4f^>YOp057Xqy_nOn{ zjPwDKoydgnug_)~(axt6>BZyaJ7t4aPEIi;4rRjogz?Ua6XAltj_~_1dqs=e2DWm2 zBGw-#eQ3s8qfo~HhL%?amRV_Il6vtFvGK_V;@fQKt|i6kaaBxC`2 zsv;Cjh>?hbbH==jdA8!T96OpZ$P2)CE7YEH3Ute1RRx6=XUwngg(%Sh_<6;najSVIrPeB?*b^*v%>~i9)a~0INT=5FFukfE#Oklqq^p%e|YvfTMzb-%!bLGzn zfR49PL2*_FowR5*F8VZTWIMD}3N=?j%B=3n;M%N<_;7pUqOvpQ+Z)f8dQbrf{pLzx zEe^ga%mY4OsbAY03Q^ejc*TaAa?Cxna9bteK2fO&hcFnP;tJr0h06TrDs!Ze80n#G zWs1w2gLlA@O1*@|wPZViYk^ok#pOa7Y6uHcT+XK;`8e$~Gs>0~J;l12W_AE|vIBlu znHLnr{+|9QUIHZy6cQ66In$GKtwU%Y3E5=N5o5jRF_Fz@%s&21C5cM8y~O(AY#EZv zx>~DFGn6J|T|OQiZ57>o)>X#&@Q#8Y*fmmLbfkKAHtQlcmdiYCYG!j8+6qBv}QNwEpnqJ9kSC2NH|5j$Uep?BPG_iF+dcdqe`#rBkNjG^%T3((ps--r}#h%Z(~9x!9+aFIv$gNg6=pGazREvAlG>Wx23LhkBb>v2RdO}h}mZmAL18b%Pzr$g`7$2>( zh@vyaJuHJm@I^a(2+Kbm#47!Ql6@kZBq#T*`W{5`Mx1pdMS@sB>a$D;{?&nwm1<5j&4@Q1fR`MV zeWD@^|5qNTUDD-_c**dX;bJ{O_Pa_dv9=pYBoq8h8_mAt)QfRUMDWfJ@Z=ia;%OTF zeY|29Gl*N6;&`|ds|c8&MS52SqY;TG8-IYGLB$~Btg5Cxk!o+lT`_o~-OjgoBl3es z8QAT72Jee11Qj+-r|fVoIj{W@7sxSSJ$T_a4e&wLOKcaH_0-Nu{7220d!XY$5{F#2*~6V_aW*aVn^!m@M2BSB95JLD~u^ap{NvUiTo| zi*|Gu+9e)GNi8WzS^+n^bO9kIVUTngFMI_&?9$aJYZ86BZi6#`tSG5eeQ}=lx<;@KsTIl zy|RpARmv(^<_|uS@NQ7M4QSO-1$$99TdU~?76iI!^>`~4pIhe&2;E?D8&(D5k)S}? zZELj>fkq+h*7wh;>L3dkX^zR_T~^due?xx)<75;izOz3Xr7;mP$g)P^7Ppp06-t}j z@BR1HEgLY5*)y@BVr~afc-oBtaU__aNhG?13%I=)ZSW_vuVB_}z!nKvudI+g@VZ;Q zs*m*G)Bkz^JUM9G;-OyIWcEN2_G7(CtT1I=I**d?(v?x~vbo;FGCff3(PHTn({3H! z0(qhjEXjHkzB&a3bfxhDUN&j+dFv5l2dDEeEZr7O?(t}ou>@|Pwn_sm(+hh%dDo`X z$w(RK=KxPK`4;}Z#GrCCI2AIz@Ewm%e(5{m0r;f|&UE|Nl>k={rWGh^HxZM;I>GQH!pah0z9 zF2b{Ubr=fLodrGi;(Rz;yv$1{d9nE3;vL*4^%b6FGQEgbM=|3ZCAy~Hw5_y|N)*6M z8zm(BT^H+1tmkLRdGx_OUY!${mtOE*i>imE>atX48peg^G4f7{j|n15aB8$*+SO=~dZ#b=o={Dm`u7JUuc6}jw6QGIn; z^Spt`NYy;nh6F4Xi&1~gFgEBdX@MeSqyp7MUaf9_WcK?L`*+UOgXd&23Bz8@{HP#V zFH6iQOa7H|6)n2b27E0U@yfxHNn68W6h@Lnaatbc@@-s+HH$`tf|4ZMT%&R*VIg^T zT{svDw-fwdYF@i(E}vVMb-hqSiChwn*8Kb?huo(KISK!}W>GKdn34#gt0UD|X(5BA z1u|O`mho1qgrh=lhLl%!v;AaxJ1%8HzKlTi`h~#H+MCx^964rwc6^7*1CMp zR#4)(8s7J*kVRA6b92yV5lRmZ$X*fi_b|(>fh#^83cq5ArnvlCGJ|CM!pN!AGJNGm zR<+l?$)VSWD6Y%OAz9W{=O_F10SdvQWTY#cR7^^hgCZ~UoVPH*Mi;qH@>Exr(}_MK zVT^_MLpF%4EylX=M6JGEwnw_U^y21>{eyBWV`Zv7D4)zttFSWlgIboM*y}jOUgt3O zlB?1lmMqlMmmIheuGHq#ARyVF@YfC&j#N{&MGUwRLUoV!^(Vr_87kLNts!kp z)G0~Wjc`kyHX5VK21Trxf7mwGHOuvZjdfHbh}CWOvCK`dqfUpFNW!ClW6YGQBWR{h zn+(VMDeDkfdvP9`oK)STXl`im$2jG`jvl%?`kOk@>qW1;4a*P=t1LycKC08B4eLwd zhQEg9^%0CIZRU5elywv2`%x6+kwr!dA4LoZX(T&$QHAJ`^LRywF|@*%pi;xfx>;r| zRQq+#mHm{4#_CoEZntgr1^tvAt%W=MItPvTYwz-}g&lsaf<|k9&G-l3V+j1RpLpFX z1>;i0hpuIcD=s)z_%)8IR%>C{uXh9m{IY`>zZQ=Ab#f2$Z%2LMgn!Kc&;E7r3%@2I z;#V0eSO@R>)$t1Qck5uruXoB{Nn~AP{)_bo`285YtP5b^*EXN>=fed*m1|Bjf5E>* z>tp}pPI(DAI~Gyv@&RwtanyLO@Ls%fGTM|?(})4C!ET1y`V;dLukfw)ltteRTk229 zTaZ)hqzt?TzErOkqHZ@2x4_rybLpd#2!6HEb*O$nmI%>QW0Z$aov9Gj`HK;34 zl%6&bPJRO=3IrA!w24R;*0m@Jqo~6RWeqei(4fNkluh4Rc2Z8wNAW>U!O6km9wqH# zCI$C%NEgXdZlPxag*%xPcv1GJ2>+Bgk0OG5q)@*9dJ9WYt%%2 z3Aeid+nXD;QA{Z?&_Jmwsl)!~p*x#WUHs>pCQBDAnpTY%EE_s8KU+bTJHrU=+!scgJBjAL&P?Z%8=Ep+Pu|%S{nw@~ z@YyDVQ;H-5| zb7cIrrAxQKjY~Cg-)evDut>LJ#6XBNqZ{bimFhVGYdxIA3d%A38S@jyC|*YW`NW**A#%@hi#fVMTIj8%*N9RH@_AIe zF{}(sV`&DzA;VhmHkot*lGb51BFU70GfTy-tm}>@MPQ7Wu2F2N6oCTP3$vS=vW=MR zE+s4~q7R#<(dQ}Dr_pa*!j}cw#ipjhCWR7FAai-`@btDvYtRUl$O6`nW);S;%w4c$ zDZV+xLm02^ZhBgd1GmC~<{T%=j~tThZYpgSn@i9tY=yCAy;D%cm%zVWN&_FwzT2EG z8863Zr5w%TR(Q2pKR-F!{BkqPY=u8I>*nTVnN@f9TFxj3VQcFmIW?ZYlKWcG>!Wnq%=b54HXp%w=>Dd)=KES1mPUwO#D-Bc zSa&p$(Hev=wB~ijL!pHP?rgok$%c~yRwr_b#EK@MX>{NC;iu7Y>qRO+K2Iw&7aW8kOU@6C9>X(L6T3XJZi z44;XojWmlCWTWedoc7h=?NE*5^ejQ0%K~^CbdQ(K4cK0cqnFLSsA7kUN~}M`SD+H> zGq|54%hI~5k1Pf>mz(t|l5@;oBKVb!kXnI>VYhC@Ok-xn@o=X5Tx9PeY)RM(MQ4{~ zI*+f&be-!yyl8mEPGNinKHad(Gb>U;raL7@Pc6eQEVC{;k&;);pXH@xM~x+@{KSJE z{GN^Y+ateKIZ<+ms|WZyk@qZ~o@|JZz$R&cf08)O(a|UcPO4@p7t9+RQ(7P|0inOMxU9_kn(yPA;KR zjc$g@$KF6 zqxbzV+J;X@F{bEff+o2<%7URZ%dOJh| z+T=iA$QaOWhgAWM6p9)H`t5LAK-(AWLa<>wYz?S`I4y5GJQ&bmzHAIE-VToh@Dt9} zXz&9Rt89m_1TDm%o2rxXF`qn|v*x=?)FNM0-3J&|0r$v7;$Y`TU4j%?eV zXnIgqma)u(kk_trAP=zKFj$Bmn6*FIzAZ4)&Ui~Im)w8%UH^2iya)QM{n~f!^hJB^ z(v^X)bUX;d?FI)uG6aEW9QSmO}*vXkUawg#~C|#Fq^P`-F+fzoo4&=N5jm62I5{>l{Y8f>E*X z%_0xOMjkCw%0{1Z?%9bSY;8(;Hl@7O#R}{ffa%DY+u~k%%@4xS3%ia0XK&4S0!+B5PR} zA!2Zc6UfGp5xf}CwUeWI+C=$?2DSwacw8Zd8Sv@A#g6ZFGzY&F)WUazIwz^#u^>L7 zt7gz*Q;h9)_kj+M1d(+#NN3*0y%}WKp9NV)2d9GCrbe;?`N6Y62mZVnJk3l7>1}p0 zc((M-Aekr~{3(bmL#?G#o(*2Cr{83gi4cvO1*A`^j9)+oDbmzIlYo@z`z(qGOb$FOP!NqDrVKO& z&IUgU?iQ8^?LwchMaW{+)d1hY%BK%M$H4ePi(j+|IoS3|@l|g3^K#08#SwvuP!#DB z{=W-4DK0xzimYne{Kiw?xCd2_Tj{1h0s>!9*g|gD(+rDuVBqW;_p} zJ=0MkD(H5J32`n@1yF&LtvED{n#wWW~ro3VAGCG zr=*Tx(}T@=NrnFti-4_wgd~zkuM#_9NwwPTZpBu=q{IJpg@`<1-T}8r+Fq=cy4?=g z0b3>gngONzg^nHYc}d?F>r1YVx!t484%jVeu