From b701e46bb0ea529e2c5fb942ce89c6fc7a64dbac Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Wed, 9 Oct 2024 04:20:07 +0200 Subject: [PATCH] Update cpmfiles/ including binary v4th.com --- 8080/CPM/cpmfiles/v4th.com | Bin 13440 -> 13440 bytes 8080/CPM/cpmfiles/v4th.fth | 8 +- 8080/CPM/cpmfiles/vf-bdos.fth | 148 ++++ 8080/CPM/cpmfiles/vf-bufs.fth | 190 ++++ 8080/CPM/cpmfiles/vf-core.fth | 1557 +++++++++++++++++++++++++++++++++ 8080/CPM/cpmfiles/vf-end.fth | 36 + 8080/CPM/cpmfiles/vf-io.fth | 189 ++++ 8080/CPM/cpmfiles/vf-sys.fth | 222 +++++ 8 files changed, 2348 insertions(+), 2 deletions(-) create mode 100644 8080/CPM/cpmfiles/vf-bdos.fth create mode 100644 8080/CPM/cpmfiles/vf-bufs.fth create mode 100644 8080/CPM/cpmfiles/vf-core.fth create mode 100644 8080/CPM/cpmfiles/vf-end.fth create mode 100644 8080/CPM/cpmfiles/vf-io.fth create mode 100644 8080/CPM/cpmfiles/vf-sys.fth diff --git a/8080/CPM/cpmfiles/v4th.com b/8080/CPM/cpmfiles/v4th.com index 125ca69d2a3b77e2840364da41128b05793b7bc4..5c9021383bd57d98ec8e2997553ba3c5fac8dd4c 100644 GIT binary patch delta 5801 zcmYjV3wT?_l^)G~N>*$=99zDUA9}^IDG|&Xh_-uA)@6~gS(-D^+!y%z?KHkLi2?!TjIcONGW*F+$*>B z_xWhfKWEO&IdkUBnY(N2uB}g8Xj+0WLRifgn-Ki2#JE&#%9u^(3(}~p_h=hT9XBGp z5z{$E$%`1_J(yM0^y+kOPOzE~z8B*{WX#PYd;nt=S{8(VjBzqQ=C&gI3<#%E1-Urp zu0{AIOvj~yJm$6`{5tfMiun@sI1qjZGwGbp)Fb>6w#urisKZh&nUU488{G{E{~zW@ zm4ui{=SIfdE`%)7oio?U9iL;0lYD)a(6W)6R2mm1B^$1@_-5gWzre;AR{PplP29EG<>Si_e z2pPA*Kk5hcH@dzbQdk{&z6u-AQR+4|sVez52tb&Ik`|gO(A@a zVg}`P>0&Ki*>Uvc)0D1}rrF3Uf(8isY87pwIeDF&C>7;?x-#7d`i7{*mm@6EI5D(= zu3WVQ=?1R_-g^~YnY~6=wuPosnRNa}P_=oRE^r;qC5p=G)fxF-khH-*Y(A}K)E0^UZio<`>p}|7y9s9G!A<|Bg$^M-hacl4Tb+h)5Hfg zOhwm^8M?4m$_q^81AP^ChDw(59Zco-I_qWVLEu*~#Nr{w03!^ojLK?`nFXmZ{u;tE zL#aw}0{|ZYfbb|o<~blt)-oco^6weeyVq z6?HAJJD%FI^N8W=JWD}bPY`hbmYoL-a1%?dQ`DOX`1qEchYawWER|D=-)Ad3dbaHB z=`_H*S(Er9cDAxp+qUChw&=6$XW5**S}Mv@Y$ZH>AB(hOj29MtnrVYYf5hV6u$`;; zby*9Cqv2NI4A#ZrzHm2T4ZfYjOT#g)Vy6+YU>I7g-a>dehkM2K9LzwDmhMU2)y&eS_6m;if(GezeF zl9GPPnfm4g3R*wsOiSkk8d}pF7D14xn&GgLdylKc=CAh~QS~-QL5?}gRen1CUmU{! z%~6?j(ZpM}QI;((N?+}Hj!po$7{Db+hqM-M6*#Ar$EATy{A^`rHUHZZ4;e(4znC`- ze2bu2f=*9BcDoiNV|ViqRpY?z=1sAEgxLYi_jnu`ILKEz7G(DW5PO!d?0Du+6a3Ma zs~U~~y6Oa=M_)CNPJEoFA_K7x2(}>g4sTlZ8ED@5+{+XEj%R^Pmw2Snd;pfqn5krB zRn!df71A>cvv-{;Gx;ZZw#8Gnj;fS+I{7$Q(G z)1|DmZl}323#PwuyZH~g;nxy4ox9h72d8f~Bm5mR1(J`MM?o~p>(C@X>Dmu5w$^iG}B1{Kdpk({{g}JCGYw>gugO# zgK<^LC5HVL;vzF7cs)xrTG+S(N4U^$fn!xYuo25{m?{HT(i#gSR1%~MDRrZ{(~a;Y zmRm!EN#$M`15Uic0`9!RGHtdX?O}5O&c<^3u{W1 z^RiSd3rAqcYc|eu(n`AR*2WORjz#gLLM9o9NnX$=>0FcmClc(R7cebvg#)WyX>|kL zZH)mvW+fi|gLP>$!XGa(b(V#hMP@z9ytO#mc|mQZg9Mj0uxJ3}zPYFu=%Gb};Nioy zbWc`EmW4a18S??^=~`mh$F-)OvhZoG5vZm*N|*Sw)=*hj$8;`?nOn3lrnL@t!l3p# zW6-iXrep|BaxUf;U2U?CEhQI5PIAvu+Sb}ySjj)thJZd)+XHmAHVpoIqmIdEqy+5c z$8{4laZp{|V(1Ol1!2ugY>ccz6;l=_IZ@xwjEx?aRe6ieZbeXIG)+GOR&1~_QYNDm zcm4(aUqG+1nYu`bJVhVjw(EoU*l5vHYXoX>F4<;w%rLOn@?-U z>l~zzveEuxI&M^GAJvUr0BO%g#nL&Wnpjt|Xw~^c8-*x&&Tc8EuPwaF;$`^=+mCcUFezpCpOW*!#`-wN(HXcV>#J(6rdL2wD zpO@7&j@d$`e(|d!-Y^qzT;rcEIgs}E_6MM-+vMOgij+*HGu2wM))4}@&PlITRItzG zoNy5D4m)}w{L)T3CuPB{Ccta9ma0f+y%Z`7PQGJ} zvt4&~e|@}r0nx{37dsnEu%-3!v9YpHw^+WH|}v^=4uc;E}*IUJAwYXJ^{3G@f|=PT-*lq zrNs?E-(KtixBq7YtIDG?(K6HEwOG(*?vL*Mv_6OCXz1uh*x6`KXR~rL4L&1t4Fwy? znpQRPkaUV_Isxb3$?wupZEFK@=bnavMuflJ2yras%fgTFe%i^idgy7tYmgy#oNQ!6 z{Rt%r8V^v%8}`#Jf-z@*qo5!>;9>@0Y|@CiwJy_+var#$pSIF(a2s8Q2R6HsuyV*s zWHsAeU_*L!mAk{08vZM*J>1w2aq@_Z&q^cmXj)!7<(}k_HrIGLto3Uy60>_;B=h{r z)d%#?E*H?nO>JI;8w4g6SCZ??LbIO1mJ1AFV{n@EOgP%K6lA~CM65p4EQ}z^YR%Y+h0evO47sv?7gZxj{sj zZIvz}mr0=YnO5BT1Lqlii*9Q*f!29$O%*+8$+>_aqsq-P1;HyTffwK##R`LH>Wm%jQ+c#lAltNXyq)Q&yy)BAJb0oDR+$zVYiPqgr0(T&36AW{VA;{yf1uuPSjTVg0MsVejLxt32mU_Qa=NC1iA3W z{hcI9YCC=8?en0|1;xihemvkW3-|f&^BV{GSwHrJtJ>N7{QK$q{G{9=V=BHz7<1ki zf_eW0A`sGF`Ioa1v)6Emw%p%QMEJr0?p7iBGc)EfCKez@UKXHA1S6NVfqWx?lidV} z1+MiIk=+3k@H6H+^#S(>a7pjhS?y_m7`E_efJ*d$MMGdwB|v3*3Uh)DA?>HPAVT@DGD*x^L(;-%D_z=KEFU?*tm4UPl7KR9Sd_<gCIev<&My z*9D>B7jZ&8N8YeKB3)dcm(O*<(pQL7QqG*~V&Q{=Nav;10K*#wzIaJ648CcNiIh|v zJl6#uwZ=vG;;^=eZX>MqWHG21rVufxxqN2lWf!5VRY+gQR>a zY=dgs-yMKwwF225_jHGoaw?rm^To81D|nmX?I04T-7by-Jt>lu-`#yF(7oL^!1a1h z4+UFIZjcB2UiN&1w6-2Etlb-7;2BVmvXRQ{zh!3_G`%u{a3Vs-(+ZsEj)-CNdH_JI zER0kETZHn*;l%M^^mb?`)Hz`hw0A>01Lwg4Z7o9k1l*)b0)&BmW$wLk}+Q3 zI`l42gjDOzy-bK~eOZY1o{DS@k}ys5QlSKd+Fg-Tkq6+PU~7Bn5GoLT-~H%0asas(9kj%^Van z+TFd4D-r%~lu9MQYhxhwSd@X1P6p#9IVZp9YJI^+qP&uqb0kTTIL1 U1aca`T*@R34nERpuBDg%KL%~60{{R3 delta 5801 zcmY*d3wT?_mA?1fxev*TElYmLSF&V1Y|ECfEjtN$IkxqJ7D{($flarj3ABZTmZ#WKXanA*4Q#$*x}|Je9$MObq3sq7-KFV+>=`N9 zN50P|bN>0ynK@@>&dk-#yKdg~$XdQl0FDDAn{VPc0oDT)E;MzJlG$8jTxUHZ-OhK+ zi?9PoI+Mw2Ai-gfGDdPZnO;^cyaaav61>Y1V6!^LOxr-9-9Qe1TmQ|D|HgQ0~XydGR8y!Xp>%FhL-i7*W{1Xv&J>ip zb*6i_2_+u_8YoZ@1S31NN9c?&f&$Y__uhmA1T@&9z;(hc1I8V~5;8)c3|(8n6*wf^ zVhlXM?6&*I{fPby=_dHP0LIWW7vKu?r0_W-Ze+5rFx1bej7i^s#!(ZzDM*EMTF>Rr z3MTka5C`?m$$T{_9eDEjvqIS;AyRlFLjw$bv5cCbiOBk9Jyyu;8%Sw!C79`uP=93= zLNT69(gGlV2k$?QD3n%Y|?Tu0~m z&jPm*e&~Ku!q8X@7Wg{hy-zSN{!cQUJ}WrpE${;Zecm@Ju>V5e3ivsJkoS+w*=P3q zZ~8oQxB~uz5SD`~u~b$;B)N%5RuxNc<1DJ7RutleY=>C-O}nf!JH-bSDX#zi5W%OC9SjglnbWAwJ$pmx#vK((}YUUkjWh_OSpuq!Npu7CaK^ zV^fq$OFv`IZ4j3D&5@d`CR1Z8hbMSGNYa3)G0r&MR1CP!eJXQgBO2X!h z@o5G=G;{EH1-wBL(wY2MrP6_(nS(u@479@?60dz*S}Gl+dk_5mOc^>VNojpJlGjg4 zrO@KtQXPFk^zwD|tk^PN5AR6O8>*E{e&p7JS%$ul2epdokYQ!0o2eDOU4~Vm0l8F5 zI2OSOwxn{a9@favt8I~S1m?#;KiUjx74>6ir(K8azn*7y4X{@xd844uFRSOzH^9xZ zn24lu`m)M#4RE{6hbyfkGT*zb@`ybk^L@)IVC%awzj9d>u=PEeU$v|fY%R*5A(6Q{ zEkh>#rd%30zu(VxRRg>x3s_^`mrLJW{CBw#ek%*9WS&>ddj<21L%`WI!a1455UfYA zjVnXcEpME6fCmqM|4wD8bb46%MM1#|f_w*TQ~3TH89K($#aYDx`;a+shl0Cm8nr_T zKX8O82b3oGiUQ&O2bEGsh1g2${DIIv~&$G&t&zC(k!Q+T-d>PRvU#uXVa7q!v z{R3|^>>}%z3cvA>==tFHpPy9@JdI+ppg1W}0`pD~O+q}pvCoA366;w~oX}~4_{O3- zDZa1Vfqz#?9C5+`g8d9!BfYP9%?j5pU7?&2?p0>RS&<_y$eBoCEVB8askDTlzjCYT zcNn+}_Axk_zN-QcF5Y5t!52&dGQVXSN9veTh87S?roYEnV+vz6!=oli-<;Re@t>IR zWIm)c!#|mXNHq5bPWGwyyMS%XW_Z;^;s}0l0bKl7$xZ*JI4*U=M<#hNYDChp5x<$G z$bON6 z&)kJJn8d5hn9i%rizc&|-fs%-w_7<9fbUmHp$lND>UQg56$5`#r3@H)E|VJ988;<A`NCENh4QOze(3t+4xpETIK9$gOnwjOcd4gve*1t z)q^re+Tcn{JU^nRi|VgT56Y`8@8Vc(^h;GPdmG$o(W5$E&_&f`d7P2y531IwZSX@& z!qBsNBwth?N0XPVviWrj>#nsl2HU~5A{x)IL8ft#XVI=5I#PJWEtRt^aV?R@1Vc4tZMFn->=|1i|XkWCfsEm;H`$f&P%FG9hlV)+P|Wo@1!@Z z=;cH7_=>^#E;vz5dd4#GqWVSQwCR}eL^Vgc;P=&hPf`7#nr+lB;A@03=4xV>B&3fZ%qk7)hlv`Gfz1{wJc>TKO)vMIIxM%X4Mp!&Zoup;_|a1?Y%X z$VMP$W4cFEqrPn4FvRU2OWLwIW>gr$AVEgHS?OOk0!M2)y zy!Kw(8rW%5Qkh6RkxZ4}l51$SEr@W9olIm5jL%`8wQ*z(9kKNW*Fe%v(vdMt>$HE+ z-Yz<<8QU3wBWq#KF6Q!hyRq4Z08jk+Kcl zW^XL4gY9+E$;qNx(>7N77^ZI>TvsPergc4z=k*qQz&$Ja$Q5<0<4~P2qHktSt*=6b zdtaR#*JH`CNQ%Mc3cQ}4vS;`Ww5hHOWuoqj`~dxFU5p>3jrF&oysy56AEM9IH=um2 z-sK*Ge`}BoeOzZ=PB(bXW^PLUgYzh1V+>JSLr3=z*c(mBu`xZK#GJ9QhFTl36E-#~ zSakA6GKS~huH4Mf2;J4-;Un~LLw{ogKHrG@IFc=@--e^au1IX_Md+^@bTtaEH%h?` zu}mC29urPA93^g*jTxmI8r4h;`W@mR+Q!)$#bCn0A1JCj97liv$Z@*dcqJdFmpQt5ogQ`! z@Co{3$4ZocbvRJgH??>Z(4dL~(M)_xQEkQwmVh;?$kYKmO-!fbO{@4}`h_MB%HvJW z#$h<2KDU9LWmXV5a@cdefg{88^`>UWFub8E;}IhniKZ~_olTWXV1(M#)%*w@QCm>% zQX?pjtM1MuoN&T;`74V1fB%y3l2eWq3`0-nS%Q-E1J%zbX`^$4I|&XK$!Bu7gkJ{s=v~)2^NT7=6i=<dQ#HZv z>66Zv-B~!}ma-8eryD1o0Z*2S?whntAbBEN*<}*&Jmmq;*X-}%l5B#{d3f}CUfy&8 zeH~GQKH~1<4f?kGYCcCZo^fX$vMq8qD+GnyN#~uAZ#pI%6WGqm(~}-IpQmqnR(9p# ztro(HPElQhr*T0(+rp6o)Op2F1>I76lq4jl7g0LU;^GT*YfE!e0VcgMO~YOCpuDB_ zeKJ=2p8P1Yq+f1Pk#nM@i65sgv~8|lVsKL-iD&9>-p|(B zJhJ&u=Q%PCf=_H`_(^A#ZycOHQXxHtN9%wvQuUsE*yHyxVu!B^qe{mkMm*V5zH8n5 zui;1Xr)yYm+$Xh1qPX}h=5e6ccpDrOaE(vM#f*Ft&rQH#9~geNttRM#_Y!`BzUp0v z((0>gn1EXU3*}Gga>4tHkJZG@biJ?Dy#+S-A(~oNTevN7xnIOPf?asi{!T2CTj)Wb zkH3uG=W}#i2H)^QzrU#7?Z4a4(tQ~`?FT=ms$II=JMvp$Z2-CrEdJtY)1){M;K)|EA|MnP#xCm$@~HsCyBRPL z*ym@ILjfN3)21($4ekj*q1?^XN&198)HDfC2837-Ml{4tLMb4mdUDIEm7Ao0@+U*v z;9S6jFGekIV4Ry;2h4pMc!j;bZuT9%4PvcgHd4sx*rv0AFu#rdL!fhTJAA!WO6J%F zHtBS2hf}Re0+;^cg|;1j-b%7qj#>8E-*!0LDn@&vg~YO|knL1z?c{gR-qvaU3VKiL zVC@xfZ<`!X=0f^rZYBy`NjhPD&!ue4Wo z)D#_TSLdf-C@5EEG&B>ebzOXKOu^QmbkS@o7!Gn|3a$-`(NreJ-mk$VBGYhdP%32O z7w(0d-)+USAlJz3jWZ4R1g-2>A1$8AX%$a+&K_Ag4Nn9u<*a6Tt{SL+=fyQJxK+hs0P)k6_GG)^>4Jcp&sl`QE&mzSZgHucjol9_3)j%g@rwLzkeu zC*()@OsEOvtD*4xZuohZT=_+5eNp|Y+T}Q1>-crq$!<_IqT{?i?BaHVUxS$OVHfO% z9*yL;Wc3fb$ZlAt32{C3VVATUbd6*q!w4(80e|s|pqY6$Olm?TKlovnWj9P~_>03t zQJvM;lXN#+qX{wkxvo}zH$C3fgflsz38VU!BN~qOf<~}8ctpeTmNW^U0Cst1}*id%8n$J&{Z&m3%Uj&Uu^n(ot2%K>{6Eu>I38iDlB>qWUBGV_}Y5Pv7lnY`7lY z3roX#9`np9#1F2|zaF+Yw9#IAGOY49(qD#0QMUJn`fr3_pMvv@X0Y0SUkmj9DSW24ua6^hknh9F zVd$8go4GmI-6vza2Ve0lqf>ITJV)>7ZCpPGU+NPQG0fT|vcA(? z@Ekner)08vniVPb&Z`*>e~k@5-|Tga&cR!KBt90w4B8d7!avtXaHt`Mct^_~s#Y?j z%<(bg0L=Btabp}e7hXeSD_N;KK%;$=`~kYqm*5Z5GktgRH_`noSD`$yG8EYd53e#s zayfkrUrq+wV^ynN;eEKv#ep>bOt7qKun*o{C5~jVfGn$BsQqn~7_Vp{*hd|!uKaJ9 Co)T*S diff --git a/8080/CPM/cpmfiles/v4th.fth b/8080/CPM/cpmfiles/v4th.fth index ceb3115..88959c4 100644 --- a/8080/CPM/cpmfiles/v4th.fth +++ b/8080/CPM/cpmfiles/v4th.fth @@ -3,8 +3,12 @@ Onlyforth $9000 displace ! Target definitions $100 here! - use source.fb - 2 $75 thru \ Standard 8080-System + include vf-core.fth + include vf-io.fth + include vf-bufs.fth + include vf-sys.fth + include vf-bdos.fth + include vf-end.fth cr .( unresolved: ) .unresolved ( ' .blk is .status ) diff --git a/8080/CPM/cpmfiles/vf-bdos.fth b/8080/CPM/cpmfiles/vf-bdos.fth new file mode 100644 index 0000000..2844a60 --- /dev/null +++ b/8080/CPM/cpmfiles/vf-bdos.fth @@ -0,0 +1,148 @@ +\ *** Block No. 119, Hexblock 77 + +\ CP/M-Interface 05Oct87 +Vocabulary 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 ; + + +\ *** Block No. 120, Hexblock 78 + +\ 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 ; + + + +\ *** Block No. 121, Hexblock 79 + +\ 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? ; + + +\ *** Block No. 122, Hexblock 7a + +\ 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 ; + + +\ *** Block No. 123, Hexblock 7b + +\ 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 ; + +\ *** Block No. 124, Hexblock 7c + +\ 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 + + + +\ *** Block No. 125, Hexblock 7d + +\ 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 + +\ *** Block No. 126, Hexblock 7e + +\ 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 + diff --git a/8080/CPM/cpmfiles/vf-bufs.fth b/8080/CPM/cpmfiles/vf-bufs.fth new file mode 100644 index 0000000..8105105 --- /dev/null +++ b/8080/CPM/cpmfiles/vf-bufs.fth @@ -0,0 +1,190 @@ +\ *** Block No. 94, Hexblock 5e + +\ 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 ) + +\ *** Block No. 95, Hexblock 5f + +\ 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= ?[ + +\ *** Block No. 96, Hexblock 60 + +\ 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 + + + + +\ *** Block No. 97, Hexblock 61 + +\ (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 ; + + +\ *** Block No. 98, Hexblock 62 + +\ (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 + + + + + + + +\ *** Block No. 99, Hexblock 63 + +\ 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> ; + +\ *** Block No. 100, Hexblock 64 + +\ 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 No. 101, Hexblock 65 + +\ 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 No. 102, Hexblock 66 + +\ 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 ; + + + +\ *** Block No. 103, Hexblock 67 + +\ 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 ; + diff --git a/8080/CPM/cpmfiles/vf-core.fth b/8080/CPM/cpmfiles/vf-core.fth new file mode 100644 index 0000000..374117e --- /dev/null +++ b/8080/CPM/cpmfiles/vf-core.fth @@ -0,0 +1,1557 @@ +\ *** Block No. 2, Hexblock 2 + +\ FORTH Preamble and ID uho 19May2005 + +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" + +\ *** Block No. 3, Hexblock 3 + +\ 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 + + +\ *** Block No. 4, Hexblock 4 + +\ Assembler Macros 20Oct86 +Compiler 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 + +\ *** Block No. 5, Hexblock 5 + +\ 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 + +\ *** Block No. 6, Hexblock 6 + +\ 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 + + +\ *** Block No. 7, Hexblock 7 + +\ 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 + + + + + + + +\ *** Block No. 8, Hexblock 8 + +\ 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 + + + + + + + +\ *** Block No. 9, Hexblock 9 + +\ r@ rdrop exit unnest ?exit 07Oct87 +Code 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 ; + +\ *** Block No. 10, Hexblock a + +\ 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 ; + + + + + +\ *** Block No. 11, Hexblock b + +\ 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! ; + +\ *** Block No. 12, Hexblock 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 + + +\ *** Block No. 13, Hexblock d + +\ +! 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 + + + +\ *** Block No. 14, Hexblock e + +\ 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@ @ ; + + + + +\ *** Block No. 15, Hexblock f + +\ 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 ; + +\ *** Block No. 16, Hexblock 10 + +\ -rot pick roll -roll 11Jun86 +Code -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@ + @ ; + +\ *** Block No. 17, Hexblock 11 + +\ double word stack manipulation 09May86 +Code 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 ; + +\ *** Block No. 18, Hexblock 12 + +\ + and or xor not 09May86 +Code + ( 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 + + +\ *** Block No. 19, Hexblock 13 + +\ - 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 + ; + + + + + +\ *** Block No. 20, Hexblock 14 + +\ 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 + + + + +\ *** Block No. 21, Hexblock 15 + +\ 1+ 2+ 3+ 4+ 6+ 1- 2- 4- 27Apr86 +Code 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 + + +\ *** Block No. 22, Hexblock 16 + +\ 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 ! ; + +\ *** Block No. 23, Hexblock 17 + +\ 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 + + + + +\ *** Block No. 24, Hexblock 18 + +\ comparision words 18Nov87 +Label (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 + +\ *** Block No. 25, Hexblock 19 + +\ comparision words 18Nov87 +Code 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 + +\ *** Block No. 26, Hexblock 1a + +\ \\ 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 ; + +\ *** Block No. 27, Hexblock 1b + +\ 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= ; + +\ *** Block No. 28, Hexblock 1c + +\ 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 + + + +\ *** Block No. 29, Hexblock 1d + +\ 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 + + + + + + + + +\ *** Block No. 30, Hexblock 1e + +\ 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 ; + + + + +\ *** Block No. 31, Hexblock 1f + +\ 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 + +\ *** Block No. 32, Hexblock 20 + +\ 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 + +\ *** Block No. 33, Hexblock 21 + +\ (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 + + + +\ *** Block No. 34, Hexblock 22 + +\ 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 + + + + + + +\ *** Block No. 35, Hexblock 23 + +\ 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 ; + +\ *** Block No. 36, Hexblock 24 + +\ 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 + + +\ *** Block No. 39, Hexblock 27 + +\ 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 + +\ *** Block No. 40, Hexblock 28 + +\ um* 16May86 +Label (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 + + + + +\ *** Block No. 41, Hexblock 29 + +\ 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 / ; + +\ *** Block No. 42, Hexblock 2a + +\ um/mod 14May86 +Label 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 + +\ *** Block No. 43, Hexblock 2b + +\ 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 ; + + + + + + + + + + + +\ *** Block No. 44, Hexblock 2c + +\ /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> ; + +\ *** Block No. 45, Hexblock 2d + +\ 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 + +\ *** Block No. 46, Hexblock 2e + +\ 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 + + + +\ *** Block No. 47, Hexblock 2f + +\ 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! ; + +\ *** Block No. 48, Hexblock 30 + +\ 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 +! ; + +\ *** Block No. 49, Hexblock 31 + +\ 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 ; + + + + + + +\ *** Block No. 50, Hexblock 32 + +\ \\ 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 - ; + + + + + +\ *** Block No. 51, Hexblock 33 + +\ skip scan 18Nov87 +Label 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 + +\ *** Block No. 52, Hexblock 34 + +\ capitalize ohne Umlaute !! 16May86UH 25Jan88 +Variable 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 ; + +\ *** Block No. 53, Hexblock 35 + +\ (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 + +\ *** Block No. 54, Hexblock 36 + +\ (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> ; + + +\ *** Block No. 55, Hexblock 37 + +\ 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 ; + + + +\ *** Block No. 56, Hexblock 38 + +\ 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 + +\ *** Block No. 57, Hexblock 39 + +\ ." ( .( \ \\ 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 ! ; + + + +\ *** Block No. 58, Hexblock 3a + +\ 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 ; + + + +\ *** Block No. 59, Hexblock 3b + +\ 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- ; + + + + + + +\ *** Block No. 60, Hexblock 3c + +\ 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 ; + + + + + + + + + + +\ *** Block No. 61, Hexblock 3d + +\ 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 ; + + + + + + + + + + +\ *** Block No. 62, Hexblock 3e + +\ 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 +! ; + + + + + + + + +\ *** Block No. 63, Hexblock 3f + +\ 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 ; + + + +\ *** Block No. 64, Hexblock 40 + +\ 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! ; + + + + +\ *** Block No. 65, Hexblock 41 + +\ 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 ; + +\ *** Block No. 66, Hexblock 42 + +\ 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 + + + + + + + +\ *** Block No. 67, Hexblock 43 + +\ ?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 ; + + +\ *** Block No. 68, Hexblock 44 + +\ 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 ; + + + +\ *** Block No. 69, Hexblock 45 + +\ 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 ; + +\ *** Block No. 70, Hexblock 46 + +\ >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 ; + +\ *** Block No. 71, Hexblock 47 + +\ : ; 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 , ; + + + +\ *** Block No. 72, Hexblock 48 + +\ 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 + +\ *** Block No. 73, Hexblock 49 + +\ 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 ; + + + + +\ *** Block No. 74, Hexblock 4a + +\ 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 ; + + + + +\ *** Block No. 75, Hexblock 4b + +\ 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 ; + +\ *** Block No. 76, Hexblock 4c + +\ 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 ; + +\ *** Block No. 77, Hexblock 4d + +\ (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 + +\ *** Block No. 78, Hexblock 4e + +\ 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 ; + + +\ *** Block No. 79, Hexblock 4f + +\ notfound 17Oct86UH 25Jan88 + +: no.extensions ( string -- ) + state @ IF Abort" ?" THEN Error" ?" ; + +Defer notfound ' no.extensions Is notfound + + + + + + + + + + + +\ *** Block No. 80, Hexblock 50 + +\ interpret interpreter compiler parser UH 25Jan88 +Defer 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 ; + +\ *** Block No. 81, Hexblock 51 + +\ [ ] UH 25Jan88 + +: [ ['] interpreter Is Parser state off ; immediate + +: ] ['] compiler Is Parser state on ; + + + + + + + + + + + + +\ *** Block No. 82, Hexblock 52 + +\ 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 + + + + + + + + +\ *** Block No. 83, Hexblock 53 + +\ ?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" ; + diff --git a/8080/CPM/cpmfiles/vf-end.fth b/8080/CPM/cpmfiles/vf-end.fth new file mode 100644 index 0000000..4e7bfa6 --- /dev/null +++ b/8080/CPM/cpmfiles/vf-end.fth @@ -0,0 +1,36 @@ +\ *** Block No. 116, Hexblock 74 + +\ 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 + +\ *** Block No. 117, Hexblock 75 + +\ 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 + diff --git a/8080/CPM/cpmfiles/vf-io.fth b/8080/CPM/cpmfiles/vf-io.fth new file mode 100644 index 0000000..61860ee --- /dev/null +++ b/8080/CPM/cpmfiles/vf-io.fth @@ -0,0 +1,189 @@ +\ *** Block No. 84, Hexblock 54 + +\ .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 ; + + + +\ *** Block No. 85, Hexblock 55 + +\ +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/ ; + + + + + + +\ *** Block No. 86, Hexblock 56 + +\ 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 ; + +\ *** Block No. 87, Hexblock 57 + +\ (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 + +\ *** Block No. 88, Hexblock 58 + +\ -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 ; + + + + + +\ *** Block No. 89, Hexblock 59 + +\ space spaces 30Jun86 + +$20 Constant bl + +: space bl emit ; +: spaces ( u --) 0 ?DO space LOOP ; + + + + + + + + + + + +\ *** Block No. 90, Hexblock 5a + +\ 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 ; + +\ *** Block No. 91, Hexblock 5b + +\ 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. ; + + + +\ *** Block No. 92, Hexblock 5c + +\ .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 ; + + + + + +\ *** Block No. 93, Hexblock 5d + +\ 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 diff --git a/8080/CPM/cpmfiles/vf-sys.fth b/8080/CPM/cpmfiles/vf-sys.fth new file mode 100644 index 0000000..4686808 --- /dev/null +++ b/8080/CPM/cpmfiles/vf-sys.fth @@ -0,0 +1,222 @@ +\ *** Block No. 104, Hexblock 68 + +\ 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 ; + +\ *** Block No. 105, Hexblock 69 + +\ 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 ; + +\ *** Block No. 106, Hexblock 6a + +\ 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 ! ; + + + +\ *** Block No. 107, Hexblock 6b + +\ 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 ! ; + + + + +\ *** Block No. 108, Hexblock 6c + +\ 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 ; + + + + +\ *** Block No. 109, Hexblock 6d + +\ 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 + + +\ *** Block No. 110, Hexblock 6e + +\ 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 + + + + +\ *** Block No. 111, Hexblock 6f + +\ '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 ; + + +\ *** Block No. 112, Hexblock 70 + +\ 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 + + +\ *** Block No. 113, Hexblock 71 + +\ 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 + +\ *** Block No. 114, Hexblock 72 + +\ "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 + + +\ *** Block No. 115, Hexblock 73 + +\ "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