IMD 1.16: 7/09/2007 11:08:47 FIG FORTH Source            PIP COM:FORTH5 REL@ FORTH5 COM0 NUMBER PKG FORTH5 HEX4THCOMP COMd4THCOMP5REL- FORTH5 SYM !MACTST MAC"4THCOMP4TXT#$%&'()*+,-./0124THCOMP4TXT<3456789:;<=>LINK4 SUB?FORTHBASREL)@ABLINK41 SUBCFORTHDOSTXTDEFGHIJKLFORTHVM TXT MPRINTER PKG NPOLYF PKG OHEADER PCASES PKG Q4THCOMP5MACRSTUVWXYZ[\]^_`a4THCOMP5MACbcERROR PKGdSTACK PKGeTRACE PKG$fgh4THCOMP PKGijFINISH4 DOCkASSEMB PKGlmCPMORG PKG0nopDEBUG PKG qFORTHBASMACrstuvwxyz{|}~FORTHBASMAC0(INP:/OUT:SPACE)(INP:/OUT:SPACE)(INP:/OUT:SPACE)(INP:/OUT:SPACE)(INP:/OUT:SPACE)(INP:/OUT:SPACE)(INP:/OUT:SPACE)(INP:/OUT:SPACE)(INP:/OUT:SPACE)(INP:/OUT:SPACE)(INP:/OUT:SPACE)(INP:/OUT:SPACE)(INP:/OUT:SPACE)(INP:/OUT:SPACE)(INP:/OUT:SPACE)HEXDUMP PKG FORTH5 MACFORTH5 MACFORTH5 MAC4THWDS TXTFORTHBLKMAC/CPM PKGHSHOW SUB COPYRIGHT (C) 1979, DIGITAL RESEARCH, PIP VERS 1.5$$$ SUB =.:,<> _[]INPIRDPTRUR1UR2RDROUTLPTUL1PRNLSTPTPUP1UP2PUNTTYCRTUC1CONNULEOFDISK READ ERROR$DISK WRITE ERROR$VERIFY ERROR$NOT A CHARACTER SINK$READER STOPPING $NOT A CHARACTER SOURCE$FORTHBASBAKFORTHBASBAK04THCOMP5BAK4THCOMP5BAKABORTED$BAD PARAMETER$INVALID USER NUMBER$RECORD TOO LONG$INVALID DIGIT$END OF FILE, CTL-Z?$CHECKSUM ERROR$CORRECT ERROR, TYPE RETURN OR CTL-Z$INVALID FORMAT$HEX$$$$NO DIRECTORY SPACE$NO FILE$COM$START NOT FOUND$QUIT NOT FOUND$CANNOT CLOSE DESTINATION FILE$DESTINATION IS R/O, DELETE (Y/N)?$**NOT DELETED**$$$$$$$NOT FOUND$COPYING -$REQUIRES CP/M 2.0 OR NEWER FOR OPERATION.$UNRECOGNIZED DESTINATION$CANNOT WRITE$INVALID PIP FORMAT$CANNOT READ$INVALID SEPARATOR$1 :2L> ̈́M9 221@:2!o6+6+6!6#6!6#6:G*o .!N6:^*M^!K6!6!6+6' :$::=2K  :ʤ\:ҷ\x'Ͳ:!\͢  :͈'! :$: $͈Ͳ!N6' :!Cwͯ !6:^͢c!6{:/>!/H{ͯ :<2Š ::=HҮͯ !6:Ҿ:2 !6::/H͈;!6:> !/>HHͯ :^!w:<2:0}:@E}:!S!W6: z!]6:cm!c6:_z!_6l ::,: HHҰͯ : 2ó:E:1:2v!q!*8!*6: >ͦ>ͦ!q:_  !p+q.*   !q*&!p+q*2!p+q*2!p+q*22!p+q*!p+q*!p+q*!p+q*2!p+q*!p+q* !q*& *M *M !p+q*!!p+q*"!p+q*$!6  !kp+q*j> >ڪ Þ !qp+q/ *pDM9: :M2r:N!r !:r *r& N!r4 !6:͔: :ͳ.!ws+p+q+p+q:w=2wN *s*u w*s#"s*u#"u' !"*M^7 !x6:!xھ **DM͆ 2yʭ :yʗ ͯ *"*6:2x÷ *"!x4d !"/ !j}=2| !"*KM^'_ !z6:|!z1 *      "}*}DM͆ ' ͯ *"!z4 :e !"͆ !z6:|!z '? 2*H#"H!{6:{ր!Ң *{& :{4 2!{4m *":ڹ ͯ !z4I '2!"!q: !4>!S :S! :2*M:=O!L NE!4 E E:/.*&L 6$L9k9.Xͯ *KM^020 :020:121'ͳ':²ͯ !G6!"!"7 *M^n/ :a/:H!6:ͯ !&6! ^#V͎ * :w*#" = = = = = ͯ  *M !6q  !6q  !6q  *& !6à  !6 à  !60à  *& !6  !6  !6  *& . 1 4 7 : = F P [ f q  2*">!b!ͯ >!`0ͯ !q:E:24J!46*}a!44EJ *KM^'́:‚ͯ !36'n::0:f9OY#9.3'ͳ.:020' 'ͳ'7 6' :2!q: " *M n :c4 *M n :2!c:Q !c:2: !:cw>!n !5 Y : { !6!q:!lwҙ  â :0O !q:O| :O| !6:]2l:o'2o:n'2n:m'2m*mMͣ *nMͣ *oMͣ :]!j>A+!s!"@͓1!"<**"͓n "Dn"":!Q2҂:X!Wғä:ڤ*MEÓ:ұ@@:O2Mc;!6#6>!)*&P ~"::H:H:   *}2D" * * *&"!q:UY: Y:ҩ: ʩ:_2ʘ:€!6<:<2!ژ!6 >!]Ҥ; !6:Q::H: !6*M : !6!q:a/>z!:H:H"!6!4:_jYO jM*"S*" 3@bl*M1͓!""7 *M^͆ \͔!":͎H*#"ͧÝ/ :>͛9ͯ .*#":_!/H:_2:!q:A/>Z!/H8: 2::=O>m:W!Q} Hmd>9>!6:2*M!E ^#V͎ڗO **~2*#"m2m͖ 2m!6m!6m!6 m2m' !'6!36' :1/!aE*#">z?C9IͲÁ.!6> !ڇ*&' ~2 ʀ: y.*M!4Q>!қ:=2á:2:Ҭ\>!ҿ:=2K:2K!:!:K\: \!p+q͈*ͯ m!62m!62m!62m!62m'2:2:TҒ:2!6*ME:2::Ҳ:<22ý: 2:} >ͯ :i:2:d*M:[ DM!  ::=H-\:N2O_og_{ozg^#V))) _{ozg^#V) d^#V|g}o n_{ozgO{ozgi`N#Fogo&og H ©=¨*M:>!(:=2%> >>!F!5+N! ~2!4<2T>>!b}*bMͭz:b2!b6:<2é>!`ҥ*`MͭҞ!`6!6> :é:(!q:!wO! ~2*& :w>!:!4!6>:N<2N!> *N& N2 !p+q!6!6+6 !6: S: M!6g8:N2M*M8p!6!6!6>!ڕ*&P 6!4z!6!6#6#6!6*M8:ھ:*͇g2ê::¿::,͡A<2O>*M8):[ͱ!N5!6ñ:5!6#6>!ڰ!6:<2O>/:!O!T *M͡H~K:¡!6[–ͱ!N5:2:2!4=:[¼ͱ4:!6:.2O8: :* ͇g:[ ͱ!N5!6:%:<2*6 * 6å!q!6> !d*&I :]>!4A>:<2O* :w:?†!6!q!6?!:ҠgÐ!q*&*~!6:22: :]Hں:A2O>: 2ͯ I  %RhMD :D$Ԁl\C0q V7J Y+U @39xFVuPdKP3XX"ʥF-72CDq R+^aiKHN!*{pV`PL' d@ gr;Rǡyl14`1(t( \!B÷:S:QHI:N<22: H@"2Í202O> c!6Í202O> ڍ*&O*& !sc*&P :w:·>!ұͯ :22:_!6=!6>'!E!4!p+q*0 !z߀]U(b(hgZ`s/ef!H9%{(@ {k T }Q }Rpʓ t (#IEM- 4sUF +*Ҩ"(2 *_  6@L4yV #+l*n :V"dyMJl( E=_X&eX~SM Xt# VaZ0 Ur+s+p+q*~$7*>*>H&>*#"*#"> 2:R͎:!6!6=2:ʙ!6:“H9Ž>!6-e!6ͻ2=2ʺ-é:>>"ͻ2:!!5ͻ2ͬ!\å MåB)4ԯ 7X@Z W) ElácPR&Ie"ED6`[J^1L@Ф2i<Ž4$``\l:,~`ŅD@,:X* &hXC69L#64I@pl3Z:V!H]S,5Q("U!9/Dec}H !/ЁRҰ A5;>iY#D|Lvl-:>>!p+q:,!6*DM9:<!6:z 2W!6D*&L :w:<2Ov*:>=20O> ڒ:0:AO>Ҥ::A }}Hͬ!wͻO`idͻV[2O>2:!X!6:!7vo 0\V,AIJk.ڔzRtOiZp+p֦å`2=nE{VJ; eBrå`2ACw@xFVuXtR(0/p R+A  FT"K2EJt;i0:f*F" :X&H%f-,@bP^g1ɇKC@mU(T#90`     u UJ 2EJ:XiV;/lpVf@l:V/,@pD Jtv Xw BKXp]n$|D-V+BI$N݁P7 ^o> 6+C qUvI\|Nᝪå`ByXҾtdrPR'(%(p`W (%5ptD*)`%BpXt2"Z-<`t]` d)k@%= *p=y )0%|\pKCC)= \pK498T~/]  : kp X@  R%1B _Jzkp ~.X|vXJ_j5._r\5`5 ((E'B)` !ɥI0T$8Z-W+ j W- #?":X*rcWPF;`Z,##+5XtC`WK$7 :V0,X%p@@xFVj_xFVj`CfA-#stCP@Kht2P Khg!D#90`us/%A(Wkp JD(Mo RYVqR,å `"S:bCiO'(X-&tC@jz#WZ_o]|S48B'L~+- H$"yHI'2y4I&D[KL@ФRHҲaXKB^@ :|M @! @+"$>]0z SJzBB(%4at]0O@ Zymp=1CDR Q{% &>^j d(5WPJz'eB 9GAo%)!40eYåI ZV ~)-o XtU)ZU$S`ZuU& XaWj(X׀Z  VV0̲@A0 PH)R)--@|PI4Ե`zB"ۂP Bm+ P@ 8R$, ~)`t SX]Z  K [AP¿W0K ai==@+%([K xA`=1ddi@L"i4PL FB(`=1c %B)ḪʃXJ_zC L$" 2Ɉ_K* `A+ L,腝 haLA!xWS0Jak(E`u"I$P)Z0B\YPk S(FB(`=a(ER86+HFE9\R'Iz [AR1CbPj Aby ZL$t21MA`(YIgT@j AʭJ [CH2 UA`(q O#dV^9 N*K J [DrTR"2ŰհH!Jl[ [D2!Af`(F&1-5l e6IGm`(H&1-5lC]`ف4Ws%`t XK ^@ t!X@ L gD.aa?$i4D$J[!~/== +%1E2 L 5FYКzPP{ `A(E Pz n-hMHQWmM@)"HĒq$I'vPFWk b%1`-0 hBTԸ7Ԡkp ChtFʃXK^@ ' &` Q H"pS k L@Фa0Խ UJbV_k |% CVP{ |8% 7FvJ[F;Eͥ :V^{ Mh1@)=PhOJZfҐq YA @ +AW(TKh@0I- `4 t `Tzb)ږ0\.6*B߰K: piZD*-0=RcIZF'\56Fꈀi@S$!\Rfߡ @4HUD,:XR2y1J%=)S L`A)l@A ۀJ$)GJ%`D"@2`JBmx`Ȃm`$&` S4!Bi!+ P-01AI,%~*p% @3  T)JRMm%3\Tz0JL L@ PSj\{ b% h2a|%=)=1A~,`-4 h2qD/%=)===1AB~, -P hA Ц[kp L@)HOiT L+ sCI)~C'Zp"YPk c@DYB)~E,Xu"YPk O@@M .x8S45UyD%N@Up S0Kp%I h"j_J. WvJW ; t3@vPJS4 ߰J'I)^M')uJѱ:bWԑ; T%& h2i=W%P *IJ'~*@tlNJ'~,3 MIK'~*|ud 0JV@1B L@Ri MLYB)~C)-(EVS@zzVPb !$ǷAXKO@ L@2y4I&1nE^j`A(`=1`pETS4 v߰JzYPkp L@2iTGbр ~A\) ElR O@ > n)E!Ie= `-`A+-=@*3@RUjgŬ%|YZk AR'PTCH2ŵXJq_;O@ |D5=+-{ Z SXWW'2_0 c@(A%a(heR X0 O@@ XT%pk l5@t ɤu 1Kr IW/%P&Ԁ~ AF$AZ !BI8I'pWZb+&-j `YJz:T z-_0!ɥI0N#U k l`i0%3&[ZzT zT14G|j :d-amhy/= -a/= (U L. Vh28F T P`_k..slotPP{V.1s0`P)IKH/V@PtB 06 Y,P͸K" 3n ]fݱv CpvUfAvK6䋈@* tt49L.#IKJ~,- XK Mj% &4@U&%M `PU; g% 3R`K<g%$v]@jX@[P W+ac?1CFo%|x]@k O@ P*6YK: MXP,%=)=|7א 4(I nx@~wN0J)(ÅMfޱv S(8ͽbS6Xt: YB)0% hb1 _Ku/'1+8m`2Wk `A) @u@b)4Ei\ _k-PShJl(m3@΂@zW^@ L@EBI8E) DV `2TJ^@@ 2CFB* tBVS!I AbR CC)`E-3SցTK: SI,5 lBa<лc,1bɄ{B _K( k/EC U' , 3~, - S6ģc76)A$"V 41L@")@AjSћ WE@u@{|1L@D5S`"_j C`-1bI6-p`0_|- `0 XZb+ $-`fS41LA!ZvfW[%     oA0_n1Avf]0 n)F7R`K `A.] S$טfY{B^@ z-[bQћ g%8`t``v.m:,5~( ƁאȂ@`pQpK%wj(c5S@{~3yi\ҪW*WFcWѫ\L@*5&1QUERو =P yO1 Gy*G\yOG1y r&ar&1FIL! f i`xx } l ,ERAS] yd 1BLANK| d 1HOLČ =\1PAĝ =D1WORĶ Gy GaO3=" O\1~+ h`ύS4U]iƯ%|#T V&JmKf5~)V%} XKN d(|k-[{\OB(HE4*`Jb!Xj !8XjP KB MEF%1Ȃ@`pQpK%wj(c5S@{~3yi\ҪW*WFcWѫ\L@*5\r1(NUMBER @\y,3$&$y\rar1NUMBE yy@=-?@\= @1y@=.1yb ya&ry1-FINb  z4@y &41(ABORT ^1ERRO Ó~qqqq  qq o g^#VLI? o g+EXECUT7T2BRANCHc`i^#V+MD,0BRANCX{}c,(LOOPo*(~w_#~w#W{z#ó~#~c#"(,(+LOOPÔ(DO*(++++"(s#r#s#r,*(^#V,Dy  E ? hGy$E  (y9= /O=@y9E ) 1ID  = =_d @:  1 3 = 1CREATH y&$ N=h@A@=s1=s  1[COMPILE| yb & 1LITERAyIGI{0'  ''_!*l+(FIND6?b#_@!P_!*hb^#Vz7!+ENCLOS+{+#ʍG~£,x#ʵ~£,,EMIyX\1KEټ?TERMINA!öCyX1 = 1DLITERAy31?STAC 3mb =m=b 1INTERPRE( yKy  a R1ak ya&1aIMMEDIATU=@s1VOCABULAR٣ =  = = z1FORTȻ CMOV i`~# x,U&D}BgxDBJ Ulg+!)O GɂU[!9^q#Vp}|v!á>))ҁҐ}o|gÛ}o|gқ =x,ANT{ozg+Oҧ{ozg+XOҺ{ozg+SP!9+SP*&^#VDEFINITIONz1=) 1QUIyG  ayE OKaABOR*V 1E fig-FORTH 1.51,WARVz^*,COLĆ====&=== =^S->ğ!z+*+,RP *(+RP*&^#V"(,;3*(N#F#"(,LEAV,J*(^#V#s#r,>@^*(++"(s#r,RWt*(^#V#"(,m0}!™#+0)!Ҭ#++D!9^q#Vp}o|g+MINUӻ}/o|/g#+DMINUї_y1D+y1AB @1DAB@1MI,Ny3&1MA;NKy3&1MQN\$3$$r1Mg\\3$Yr3r31l&1/MOĩ\r13&1MO&1*/MO\lr1*>W>o>g+OVE*DRO(,SWA5+DU,B+2DU:P*+G^~w#~w,TOGGLWu~w,j^#V,C}n&+2^#V^#V,s#r,Cs,2s#r#s#r, O z l *(+p3&1M/MO\yYr3\Yr1(LINE\=@r=@1.LIN%. 1MESSAGLyy=m1Ta E MSG # X1P^!so&+P!s},DRIVůWSEWTRACWUSWqPREWqSEC/BL+q"(KB, 1. 1NOO 1CONSTAN. l ^#V,VARIABL(3l ,USEF3l ^*&+\=u=}==B̍= C/̕=@FIRSԞ=qLIMIԨ=zB/BUƴ=B/SC=+ORIGI=1SiRiT=#BUF=DISK-ERROW+BU=@?y&@11UPDAT$=1EMPTY-BUFFERK1 1DRjym1DR=m1BUFFEҘ@\+yy=y^r1BLOC˪mIi WIDTi WARNINiFENCiDiVOC-LIN*iBL2iIAiOUJiSCRiOFFSE[iCONTEXdi CURRENpi"STAT}i$BASŊi&DP̕i(FLği*CSШi,Ri.HLĺi01121HER/1ALLO/\@1@y4+y&@^1@1@y@r&1*SET-Ic*DM!S*MS*DMS,SET-DRIVX:OS,T&SCALÈ==A@?y&a=1SEC-REAĥ{$'\11C1}o|gɁ3&+-11;MzW&$%b!+!+UGNy &a11h3K1ROԉ*SPACŕ1-DUУ@y@1TRAVERSų3=Ky3&1LATES1:O*S!SSG:"2" T y :<2OS ,R/\3ar1SS S S͔!~ʵ͂͝!,+͋_! ~wk&+Mͤ, ͤ ͤ,XLF=11CF 11NF =1=1PF =1!CS4 1?ERROH 3y a&1?COMY =b 1?EXEt =b 1?PAIRӌ 1=b 1?CSТ 1=b 1?LOADINǷ G=b 1COMPIL | r@\ yb &1FORGEz1=b @'K=b @$ / z1BAC 1 1BEGIL| 1ENDI]|  131THEow1Dϋ 1LOOИ S1+LOOЩ S1UNTI̾ yS1EN1AGAI 1 y1 =1SMUDG = s1HE% =1DECIMA: = 1(;CODEL r:  1;CODb  l $1.1SPACE_yWy y1 ="y E a  1EXPECY @=?y*&@?@r1\y =a=a(@= ?yH&ya@yy1D.\33r1x 1.\r1D4y1EJ1TX1U`yJ1VLISl=XzXy yX@N:  @y&1BYyNEX=,TAS1BYE      ( **** NUMBER -- FORTH NUMBER INPUT PACKAGE ***************** ) ( UPDATED: 12/16/83 BY NAA ) : #IN ( INPUT A NUMBER, CR EXITS TO INTERPRETER ) QUERY BL WORD HERE NUMBER DROP ; : #IN.FORCE ( INPUT A NUMBER, FORCED ) BEGIN QUERY2130B78B1C21103C1C32C0182CA :2003200055AAFF022603D1E1C5447DCD4203E5677844CD4203D14A09CE00556C67C1D5C3BD :200340002B012100000E082917D24F0319CE000DC24703C98255AF1F035B03210400395E4B :2003600071235670C1E17D917C98DA760321FFFF11FFFFC3A1033E102917EB29D2810313 BL WORD 0 0 HERE (NUMBER) C@ 32 - WHILE DROP DROP CR ." # " REPEAT DROP ; : #IN.RET ( INPUT A NUMBER, RETURNS 1 FOR A NUMBER ) ( 0 FOR A CR, NULL LINE ) BEGIN [ DROP ] QUERY BL WORD 0 0 HERE (NUMBER) C@ 6C :20038000A7EB1FF5D290037D916F7C9867C39B037D916F7C9867D29B03091B13F13DC278F2 :2003A00003C1E5D5C32C0183414EC45403AF03D1E17BA56F7AA467C32B01824FD2A703C12D :2003C00003D1E17BB56F7AB467C32B0183584FD2BA03D403D1E17BAD6F7AAC67C32B01836D :2003E0005350C0CC03E7 DUP 0= IF ( NULL ) SWAP DROP SWAP ELSE [ ROT 1 ] ( NOT NULL ) 32 - 0= WHILE [ 2 - ] ( # ) 1 SWAP ELSE [ 2 + ] ( JUNK ) DROP DROP CR ." # " REPEAT THEN DROP ; ;S 0321000039C32B01835350A1DF03F6032A2601110600195E23569E :20040000EBF9C32C01835250C0EE030D042A2801C32B01835250A105041B042A2601110887 :2004200000195E2356EB222801C32C01823BD3130433042A28014E234623222801C32C0160 :20044000854C454156C52C044A042A28015E235623732372C32C01823ED240045E04D12A34 :2004600028012B2B222801732372C32C018252BE570474042A28015E235623222801D5C325 :200480002C0181D26D04F4018230BD82048F04E17DB4210000C2990423C32B018230BC8854 :2004A00004A304E129210000D2AC0423C32B0181AB9C04B504D1E119C32B018244ABAF046F :2004C000C204210600395E71235670C1E119EBE17D896F7C8867C1D5C32B01854D494E5594 :2004E000D3BB04E504E17D2F6F7C2F6723C32B0186444D494E55D3DB04FB04E1D197935F72 :200500003E009A573E009D6F3E009C67D5C32B01844F5645D2F0041905D1E1E5C32A018402 :2005200044524FD010052805E1C32C0184535741D01F053505E1E3C32B01834455D02C0586 :200540004205E1E5C32B0184324455D03A055005E1D1D5E5C32A01822BA147055E05E1D1E3 :200560007E8377237E8A77C32C0186544F47474CC557057505D1E17EAB77C32C0181C06AE6 :20058000058305E15E2356D5C32C018243C07D059205E16E2600C32B018232C08B05A005A6 :2005A000E1110200195E2356D511FDFF195E2356D5C32C0181A19905BA05E1D1732372C3C4 :2005C0002C018243A1B405C905E1D173C32C018232A1C205D605E1D173237223D17323723F :2005E000C32C01C1BACF05FB05970952098A0781057D07B80529111C0A6F0A2A28012B70A2 :200600002B71222801134B42C32C01C1BBE305FB05C109F8093104310A0E0A3104844E4F56 :200620004FD00B0626060000C32C0188434F4E5354414ED41D06FB052911310A0C086F0AD7 :2006400013EB5E2356D5C32C01885641524941424CC52B06FB0536066F0A13D5C32C018470 :20066000555345D2:2001000000C3351300C322130401000E201C0800B8711871B8711871200001002B1C2B1C72 :20012000A212050020B3B871B871D5E50A036F0A03675E2356EBE9834C49D400003F010A56 :20014000036F0A0367C32B0187455845435554C537015401E1C33201864252414E43C84850 :2001600001630160695E23564906FB0536066F0A13EB5E16002A260119C32B0181B05F064006000010 :2006800081B178064006010081B280064006020081B38806400603008242CC9006400620CB :2006A0000083432FCC9806400640008546495253D4A1064006F871854C494D49D4AB0640FD :2006C00006007A85422F4255C6B706400600048542B194D44C32C0187304252414E43C858017B01E17DB4CA63BC :20018000010303C32C0186284C4F4F50A96F0191011101002A28017E83775F237E8A7723D4 :2001A000141557FAAE017B967A239EC3B3017E93237E9AFA6301232228010303C32C0187BE :2001C000282B4C4F4F50A98601CB01D1C394018428444FA9B22F5343D2C30640060100872B4F524936 :2006E0004749CECF06FB053D010001B30431048253B0DB066C0606008252B0EF066C0608CB :2007000000835449C2F8066C060A8557494454C801076C060C875741524E494EC70A076CD8 :20072000060E8546454E43C515076C06108244D022076C061288564F432D4C494EF01D8012A28012B2B2B2B22CB :2001E0002801D1732372D123732372C32C0181C9CF01F4012A28015E2356D5C32C0185444A :20020000494749D4EE010802E1D17BD630FA2702FE0AFA1C02D607FE0AFA2702BDF22702E2 :200220005F210100C32A016CC32B01862846494E44A9FE013602D1E1E51AAEE63FC262029BCB2D07DF :200740006C06140083424CCB35076C06168249CE44076C0618834F55D44D076C061A835354 :2007600043D255076C061C864F46465345D45E076C061E87434F4E544558D467076C06208C :200780008743555252454ED473076C06228553544154C580076C062484424153C58D076C5F :2007A000062683 :2002400023131AAE87C25F02D2400221050019E31B1AB7F250025F1600210100C32A01DA31 :200260006802131AB7F2620213EB5E23567AB3C23702E1210000C32B0187454E434C4F53A1 :20028000C52B028502D1E1E57B11FFFF2B2313BECA8D02D5C5477EA7C2A30213C1D51BD546 :2002A000C32C01782313BE4450CC98076C062883464CC4A2076C062A834353D0AB076C062C8252A323 :2007C000B4076C062E83484CC4BD076C0630008231ABC507FB058406B30431048232ABCFAF :2007E00007FB058C06B304310484484552C5DC07FB0532078105310485414C4C4FD4E90704 :20080000FB0532075C05310481ACF807FB05F00CAB5027EA7C2A302C1D5D5C32C01C1D513D5C32C0184454D49AD :2002C000D47902FB05231984065B075C053104834B45D9BC02D702C30B19893F5445524DA7 :2002E000494E41CCCF02E802210000C3FD188243D2DA02FB057C065B07B8052F1931048590 :20030000434D4F56C5EE0209036960C1D1E3C316037E2317B8058C06000831048243AC0808FB05F0E9 :2008200007C7058406000831047D936F7C9A67C981AD18083608D1E1CD2908C32B0181BDF0 :200840003008FB0534088D04310481BC3E085008D1E17AACFA5A08CD29082425FA65082180 :200860000000C32B01210100C32B018255BC4A08FB054E05D203A10479010C00     2605A10470 :200880008D04610106003408A104310481BE6B08FB0533054E08310483524FD48C08A008A0 :2008A000D1E1E3C32A018553504143C59808FB059D06C3023104842D4455D0A608FB0540FF :2008C0000579010400400531048854524156455253C5B608FB0533051705B3043D017F0021 :2008E0001705E000260533052605E70AAE0831048753502E46494EC4A50DFB059D06180DAD0DF00765 :200E00007D0781058105340240058D0479010A002605F007F9083402310488284E554D4242 :200E20004552A9EC0DFB05D40740055C0490059F078105060279012C0033059F0781052402 :200E40000326059E089F07810524090054E087901F0FF330526053104864C41544553D4C908FB058A07810581B4 :20090000053104834C46C1F008FB053D01040034083104834346C10309FB058C0634083144 :2009200004834E46C11309FB053D01050034083D01FFFFD4083104835046C12109FB05846B :2009400006D4083D010500B304310484214353C004A8078105D407790108008406A8075C05720461A4 :200E600001C6FF72043104864E554D4245D21A0EFB057C067C069E084005D40790053D016D :200E80002D00420840055C04B3043D01FFFFA807B805250E400590059D063408790116005B :200EA000400590053D012E0034087C0665097C066101DCFF2605723D03709FB05E503BA07B8053104863F455244 :20096000524FD24B09FB05330579010800CD106101040026053104853F434F4DD05C09FB80 :2009800005950781058D043D01110065093104853F455845C37709FB05950781053D011252 :2009A0000065093104863F50414952D38F09FB0534083D01130065093104840479010400F9043104B0 :200EC000852D46494EC4670EFB059D06180DF0077D0781058105340240058D0479010A006B :200EE0002605F007F908340231048953502E4E554D4245D2C00EFB057C067C069E08400504 :200F0000D40790053D012D00420840055C04B304250E3305260590059D06340879010400C8 :203F4353D0A53A :2009C00009FB05E503BA07810534083D01140065093104883F4C4F4144494EC7BA09FB05A6 :2009E0004A0781058D043D0116006509310487434F4D50494CC5D309FB057F097204400569 :200A0000E1075C0481050C083104C1DBEE09FB057C069507B805310481DD0A0AFB053D016C :200A2000C00F2000710D720479010400E30431048A54494E544552505245D4EA0EFB05F60D79012073 :200F4000009507240681054E0879010A0019090C086101060019095201D51161010A00F016 :200F600007F60E9D11D5116101D2FF8A5343414E2F41484541C42C0FFB050D0D3D01580201 :200F80001705B3043305D601F20009507B805310486534D554447C5180AFB05F9083D012000730531048348455F :200A4000D8280AFB053D0110009F07B805310487444543494D41CC3D0AFB053D010A009F82 :200A600007B805310487283B434F4445A94F0AFB057204F9083D091909B8053104C53B4362 :200A80004F44C5650AFB05C109F8096F0A0190053D017F00AD0340059D064E087901060026059D06EE :200FA000F201C7058F01E2FF0D0D3D015802B3043D0150001705B3043305D601F2019005A0 :200FC0003D017F00AD0340053D0114004E0879011A0026057C067C06F201D407C705F20167 :200FE0000D0D3408E60C5C054804F201C7058F01CCFF3104874EE0A24063104873C4255494C44D37D0AFB057CCB :200AA000063606310485444F4553BE930AFB057204F9083D09B8056F0A2A28012B702B7137 :200AC00022280113EB4E234623C32B0185434F554ED4A50AFB054005D407330590053104A5 :200AE00084545950C5CC0AFB05BD08790118001705B3043305D601F2019058542E424CCB6B0FFB052B :20100000F30C810579011800E60C81053D010003B517780F7C065207B80561010800840621 :201020004A075C05310485544C4F41C4F40FFB053D01FFFF1F07B805F815CB167C06E60CCC :20104000B805520781055C047C065207B8058406F30CB805FE0F390F72045207B805F302E0 :05C3028F01F8CC :200B0000FF6101040026053104892D545241494C494EC7E00AFB0540057C06D601170517C5 :200B200005B3048406340890059D06340879010800480461010600840634088F01E0FF3123 :200B40000484282E22A9090BFB058604D40A4005D4077204B3045C04E70A3104C22EA241CA :200B600020106000480B14454E44205445585420434F4D50494C4154494F4EF302F114D4073D012338 :20108000007C067B0C7C06F30CB80584061F07B8053104872841424F5254A92610FB057CE5 :2010A00006F30CB805F302480B1141424F5254494E4720434F4D50494C452084061F07B80E :2010C00005CD10310485455250BFB053D0122009507810579011400F809480B180DF0079005D407000861010A06 :200B800000180DF007D40AE70A3104864558504543D45C0BFB051705B3041705D601D50262 :200BA00040053D010E00E5068105420879012A0026054005F2014208400572048C0634080F :200BC000B3045C0479010A003D010700624FD29310FB051F078105A104790104009D10F007D40AE78F :2010E0000A480B023F200618F403D512834944AEC510FB05D30C3D0120003D015F007B0C42 :2011000040053D09090917053408D30C33050703D30CD40A3D011F00AD03E70AAE08310413 :20112000864352454154C5EC10FB05C80E790110002605270910106003D0108006101280040053D010D00420823 :200BE00079010E00480426059D067C06610104004005F201C7057C06F201D407B805C30295 :200C00008F019CFF260531048551554552D98B0BFB05070781053D015000940B7C0652077C :200C2000B8053104C180080CFB05F30C810579010E00FE0F7C065207B8F2103D0104000618AE08F036 :20114000074005900512078105D513D407000840053D01A0007305F007840634083D01802E :20116000007305F9080C088A078105B805F007E1070C083104C95B434F4D50494C45DD20BC :2011800011FB05C80E8D047C066509260519090C083104C74C4954455241CC7511FB0595E2 05610136004A07D2 :200C4000810579012A0084064A075C057C065207B8054A078105D70684063408AD038D04DB :200C600079010800970972042605610106007204260531048446494CCC240C7D0C6960D1F5 :200C8000C1E3EB78B1CA8F0C7D12130BC3830CC1C32C018545524153C5740CFB057C067B95 :200CA0 :2011A00007810579010800F8093D010C083104C8444C4954455241CC9311FB059507810539 :2011C0007901080033059D119D113104863F53544143CBAF11FB05E503F406810533057039 :2011E0000884066509E503F0073D018000B30470083D0107006509310489494E54455250E0 :201200005245D4CC11FB05C000C310486424C414E4BD3930CFB059D067B0C310484484F4CC4A30CFB053D01FF1D :200CC000FFCB075C05CB078105C7053104835041C4B40CFB05F0073D014400B30431048408 :200CE000465054D2CD0C5A060000863F544C4F41C4DF0C5A060000864442554646B1EA0C67 :200D00004006FA71864442554646B2F80E79011E00950781054E0879010A0019090C08610106001965 :20122000095201D51161011C00F007700EA8078105D40779010800BA116101060026059DEC :2012400011D5116101C2FF89494D4D4544494154C5F911FB05F9083D014000730531048A1C :20126000564F434142554C4152D94712FB059D0A3D0181A070C4006FE7584574F52C4040DFB05F30C81058D0460 :200D200079010A0007078105610104000D0D52078105B30433058302F0073D012200AC0CB9 :200D400052075C05170534085C048604F007C705B304F007D407720407033104834D4FCEA9 :200D6000110D640DC33800C32C0184574152CE5C0DFB05F302F007D40C088A07810519090C08F0073F :20128000400781050C084007B805AD0AE1077D07B8053104C5464F5254C85F12B90A8C12BA :2012A00081A0201C00008B444546494E4954494F4ED39412FB057D0781058A07B805310457 :2012C000C1A8A612FB053D012900180D310484515549D4C012FB057C064A07B8050E0A1950AE70A480B21203FC6 :200D800020204E4F5420444546494E4544202D2D20434F4E54494E55494E472E2E2E2026AB :200DA000057C0631048557484552C56A0DFB05F007D40790053D013A00420879012D00F3BD :200DC00002480B0E434F4D50494C494E47202D2D3E200D0D52078105B3043D0120008302A3 :200D2 :2012E00004F302100C0512950781058D0479010700480B024F4B6101E7FF8541424F52D4DA :20130000CE12FB05F403590AD511F302480B0D345448434F4D50202056342E319C12B412BC :20132000D512012813C32C01311384574152CDFA12FB050213013F132A1201F9C32C014839 :201340001384434F4CC42     A13FB053D0100003D01C218B8053D0112013D01260181053D018A :201360000600B3043D01100007033D010C0181053D01A212B805021384532D3EC4411381E8 :2013800013D12100007AE680CA8C132BC32A01822BAD7813FB05A10479010400E3043104C2 :2013A00083442BAD8F13FB05A10479010400F90431048373E17DD300C32C0186455052494ED4A41876 :2018C0005A0600002A010019E9C5110300CDC418C1C9C5110600CDC418C1C9E5110900CD94 :2018E000C418E1C9110C00CDC418C9C5CDDB18C1EB21C2187EB7CAFC18CDE418C9CDC91854 :20190000210000B7CA08192CC32B01CDD218FE105FC21D1921C2181E207EEE04142D3A013FB05400594133104EA :2013C00084444142D3B213FB054005A6133104834D49CEC013FB054E0590087901040033A1 :2013E0000526053104834D41D8CF13FB054E054E0879010400330526053104824DAAE5138D :20140000FB054E05D2035C04B8133305B81324037204A6133104824DAFFB13FB05170551776B26001F :20192000C32B012519E1C54DCDEB18C1C32C013119C50E0DCDEB180E0ACDEB18C1C32C0173 :20194000C1A7B718FB05C80E8D047C06650926059D11310486464F524745D44019FB058A3B :201960000781057D07810534083D0118006509441940052A0781054E083D01150065094020 :20198000052CE7 :20142000045C04C7138604B813590372048604D20394133305720494133305310481AA163E :2014400014FB05001426053104842F4D4FC43D14FB055C047F1372041B14310481AF491447 :20146000FB055014330526053104834D4FC45C14FB05501426053104852A2F4D4FC46A149D :20148000FB055C040017093207B805090981057D078105B805310484424143CB5419FB05F0073408D3 :2019A0000C083104C542454749CE9319FB057F09F00784063104C5454E4449C6A419FB05E2 :2019C0007F098C06AE09F007170534083305B8053104C4544845CEB619FB05BE193104C2AD :2019E00044CFD219FB05F809D601F0079406472041B143104822AAF7814FB058014330526053104854D2F4D4F4E :2014A000C48C14FB055C047C0686045903720433055C045903720431048442444FD39B1410 :2014C00040060500864F50454E46C3B91440060F00864D414B4546C3C41440061600865225 :2014E00045414446C3D11440061400834643C2DE14403104C44C4F4FD0DF19FB059406AE09F8098FF4 :201A0000019A193104C52B4C4F4FD0F019FB059406AE09F809C9019A193104C5554E544921 :201A2000CC051AFB058406AE09F80979019A193104C3454EC41B1AFB05231A3104C5414709 :201A40004149CE311AFB058406AE09F80961019A193104C65245504541D43065C0084425546C6EB14400680008C :201500008546434244CEF51440065C008546434246CE001540065D008546434246D40C1517 :20152000400665008546434252CC1815400668008546434252C3241540066B0085432E5220 :2015400045C3301540067C0085522E5245C33C1540067D00115C00CD050016005FC1DD1AFB055C0499 :201A60005C04451A720472048C063408BE193104C249C6531AFB05F8097901F0077C060CA3 :201A8000088C063104C4454C53C5701AFB058C06AE09F8096101F0077C060C0833058C067D :201AA000BE198C063104C55748494CC5851AFB05751AE1073104865350414345D3A61AFBFF :201AC00005C3FC :201560002C018742444F53434DC4481540065415834452C16215FB058406F114C70531044E :20158000834452C27015FB058C06F114C7053104863E464E414DC58015FB0514153D010BA1 :2015A000009D067B0CF007D4071415F00790053D010800D51307033104843E4558D4901535 :2015C000FB051415357C06EB13BD0879010C007C06D601AE088F01FCFF3104823CA3B61AFB05D30C57 :201AE000CB07B80531048223BED71AFB0526052605CB078105D30C17053408310484534994 :201B000047CEE61AFB059E08A104790108003D012D00BB0C310481A3FD1AFB059F07810515 :201B2000A3149E083D01090017054E0879D010800B3043D0103009D067B0CF007D40714153D010800B304F0078B :2015E00090053D010300D51307033104894B45593E464E414DC5B915FB05F302480B1945E3 :201600004E544552202246494C454E414D452E45585422202D2D3E20100C07078105D4076A :2016200090053D013A004208790120008C0652075C0108003D010700B3043D013000B304BB0C3104F0 :201B40008223D3161BFB051A1B17051705BF038D047901F4FF310483442ED2401BFB055CFC :201B60000433051705C713DC1A451B041BEB1A720417053408BF1AE70A3104822ED2571BF8 :201B8000FB055C047F1372045D1B31048244AE7B1BFB057C065D1BAE083050707810590053D014200340879010E :20164000080076156101040086153D012E00180DF007D40790058D0479010400D51299155A :201660009D06180DF007D407900579010400C0153104872E4E4F46494CC5EC15FB05F302CB :20168000480B1143414E4E4F542046494E442046494C452014153D010800E70A48010481AE8C1BFB70 :201BA000057F13911B310481BF9B1BFB0581059F1B31048255AEA71BFB057C06911B310498 :201BC00085564C4953D4B31BFB053D0180005B07B8057D07810581055B078105A706900806 :201BE00079010A00F3027C065B07B8054005F210AE08AE083D090909810540058D04E6027C :201C000B012EA0 :2016A00014153D010800B3043D010300E70AD5123104852A4F5045CE7216BC16C50E0FC356 :2016C000541586284F50454EA9B216FB05F1143D010C00B3043D0118007C067B0CBA163DDE :2016E00001FF004208790104007C163104844F5045CEC216FB05F815CB167C064415C705B8 :2017000031048720BF037901D4FF26053104834259C5C01B121CC30000844E4558D40A1C40062C01CA :0B1C200084544153CB151CFB0531041C :00000001FF  :201C0000005B07B8057D07810581055B078105A706900806 :201BE00079010A00F3027C065B07B8054005F210AE08AE083D090909810540058D04E6027C :201C000A534554444DC1ED160E17D1C50E1ACD0500C1C32C01862A52524541C49E :2017200002172417C50E21C354158552524541C41917FB057C0650158C06B304C705501531 :20174000B80522173D01190065093104835054D22A175A060000833849CE4C17FB057C0648 :201760005217B8053D0108007C06D601000D52178105B3040C172217840650155C057901CB :20178000040048043D01800052175C058F01DEFFFC140C1731048646524F4D2EC456175A29 :2017A0000600008243D496175A06000086564D3E5241CDA317FB05A817B8059F17B8059F6E :2017C0001781057C063D0180005903330526055015B8055C17000D9F1781057C063D01804F :2017E0000059032605B3040D0DA8178105070331044552524F52202020545854874D4553B7 :20180000534147C5AC17FB051F07810579017100F114D30C3D0124000703F114D4073D0160 :2018200023007C067B0C3D01F11714153D010B000703BA163D01FF00420879011100480B85 :20184000064D53472023209F1B61012A0040058C06601432178406AD0379010E00FC143D4F :20186000014000B30461010400FC143D014000150BE70AAE08D30CF1143D01240007036104 :20188000010D00480B064D53472023209F1B31048250C0FC179718D1219D1873DB006F26CA :2018A00000C32B018250A19018AB18D121B318      ." F 2s . "RA9  P!  EXPEC sA9*2Is9 !!( 9Z9!9xOQUERH APQ 9x A9*A9xAAmM9T 2!2FIL & i`x8 } , EERAS 9$ BLANK< Z$ HOLL APA] DsWORv -9 A!AAsC"U Fs2(NUMBER P\A9,\A[ U@1qqqq 22q qq!*~=#~= oH:u**(u2*("!9"i`"*{ o g^#VTEXECUT*">22{TRACE-NEXԀ*(##"(:2*DMu;TRACţ22uXR|}ɃLI \AeA9Ae2!2NUMBE 99[ P-sex PZ9P.9" 9!29-FIN"Z :AAM9  (ABORT{1ERROҥAa9  ? *Az 9$  (9n /A@9no gDEXECUT{BRANC#`i^#V+MDE0BRANC;}#E(LOOP/Q*(~w_#~w#Wn{z#s~#~##"(E(+LOOPFT(DO*(++++"(s#r#s#rEɏ*(^#VEDIGIԮ{0  _!ClD(FIND?" ) ID|  _$  | | m k CREAT9 *k PA3A3 GAx[COMPILE<M9"  LITERȂRA9 DLITERA̯RA9?STACA- A"#!_!C("^#Vz!DENCLOSE{+#MG~cEx#u~cEEEMI9AKE|?TERMINȀ!CҚ9xCMOVŮi`~# xEUD}gxDJ Ulg s- " INTERPRE9RA 9 ! !+eA9!!IMMEDIAT @3VOCABULARcZ GA Axj :xFORT{v 1DEFINITIONӰ:AGx) QUI9x D!) ɂU!9^q#Vp}|6!a>))AP}o|g[}o|g[ =8EANo{ozgDOg{ozgDXOz{ozgDSP!9DSP*&^#VERP*(DRP*&^#V"(E;*(N#F#"(E !RAM9 OK!ABOR  4THCOMP V 4.0FEOWAR<_*EhCOLHpxpxPx&As AxS->a!zʺ+C+a9D+a9ABDABMILEAV *(^#V#s#rE>*(++"(s#rER4*(^#V#"(E-0BO}!Y#D0Hc)!l#D\uDDo!9^q#Vp}o|gDMINU{}/o|/g#DDMINUӛї_>W>o>gDOVEҰCDROESWADDUM 9MA 9M2M)F2F2D./MOk2Iw~MOĊ~*/MOĘ.2I*M/MOĺ9F22(LINE@2D2DUC+~w#~wETOGGL5~wE*C^#VEC=Rn&D2K`^#V^#VEYzs#rECtsE2s#r#s#rET  GA:xE , *(+p+q"(KBE~  NOOCONSTANE , ^oss@.LIN MESSAG^19z 9-Ak !  MSG # P d!jso&DP]x!s}EDRIVqSEÄTRACːUSŚuPRE֦uSEC/BL˰#BUFƻDISK-ERRO+BUs|9#VEVARIABL, EUSE, ^*&D5=EBM C/U@FIRS^qLIMIhzB/BUtB/SCҀ+ORIGIΌsS)R)TIµ) WIDTȾ) WARNIN)FENC)D)VOC-LIN)pAUPDATAAAxEMPTY-BUFFER p|D DR,9-xDRJ-xBUFFEZA9xFAa9FFAm9 FxFx2BLOCl-AsAAFs94M9FuFA IAFsBL)I)OU )SC)OFFSE)CONTEX$) CURREN0)"STAT=)$BASJ)&DPU)(FL_)*CSh),Rq).HLz)01As2IsHERřAALLOԦxICA}o|gɁDM9x2*SET-Iϵ%*DM!*M*DMESET-DRIVX:OET&SCALJ~A9!xV~xxSEC-REAg{$':O*!G:2  y:M z $%" !D!DU a9 aM!a(  ROI ] CSPACU Z-DUc 9TRAVERSs sP 9LATESԆ GAALF CF INF  PF A <2OER/שAo[ xq#2xFLUS99uOLOABAA9xox!2x2x--` 9xA  !~ͷ!,D_s!CS wx?ERRO 9!?COM RAM" ?EXE4 RA" ?PAIRL " ?CSb wA" ?LOADINw AM" COMPILŐ < 2A۫ 9Rx RxSMUDG   3HE  ! ~wk&DME  EM9" FORGE.GA:A" 2A "  x A:AxBACBBEGI΁< AENDIƒ< Ik xTHEΤD QLOOQk O+LOOQk\xDECIMA  \x(;CODE 2 x;COD" ~ , cFNAMS 1MZ j P2MZ j Ps3M1Z j Ps4MGZ j P5MaZ j PNOwv +HLԍv +vDɘv +Eɣv +RLív +RR÷v +RAv +RAv +PCHv +SPHv +XTH(o(  $ o(P>EX(o(sQ $ o(sPQKEY>FNAM$) ENTER 'FILENAME.EXT' --> AP:9 IAPB9(!(. PM9)Z P9+)MAKU)(9% NOT ENOUGH v +XCHv +DAv +'CMv +/STv +7CM)v +?AD4v ?AD?v ?SUJv ?SBUv ?AN`v ?XRkv ?ORvv ?CMЁv ?DAČv U POЗv UPUSȢv UńSTAحv ULDAعv U INv UDCv UINv UDCv U RSROOM IN DIRECTORYCREAT)a)).NOFIL* CANNOT FIND FILE o(  .o(sQ *ER&*m*û((ERAd*k*90*ERs*a){**OPE΍**û(*CLOSś**û((OPEN*L( s9$ *90*CLOSż**90*v UǃOUv oӂIv oۃADv oƃACv o΃SU(v oփSB3v oރAN>v oXRIv oORTv oCP_v oSHLjv "LHLuv *STv 2LDv :CNژv ĂCڣv ̃CNîv ԂCøv ܃CPv CPv Cv Cv CALv OPE*a)*9(*SETDM+"+E*RREA+8+!û(RREA-+9(Is(x6+" PT>+DBUFF`+qDBUFFj+u*SREAw++û(8I΄+9f+x9s+f+As +6+A(9f+OW( +FROM.ĕ+C+COMPILE.RA++̓RNv +Rv +ȃRNv +ЂRv +؃RP#v +RP-v +R8v +RCv +REMv +ɃJMWv Â0bCmPv0NOԈsMO֑@ssMVɡsLXɷENDIIk xIVM>RA+<+x+x+A9(x+s++A9s++A*SFIRS+R,û(*SNEXF,c,û(SCRATCX,COL.CTi,FNAME>w,o( ?$ .DR,L(P@s : .NAMş,W(s,A os k sQ A,,A99ITHEELS Ik [ IBEGI AUNTI2 Ak AGAIB Ak WHILX REPEAp ` 22I#Iε Z +#IN.FORCŝ  Z 99 P 9 # !#IN.REԳ  Z,9,x!  : DIһ,,9,x,P,9$9s,x,a,s,x9,!o(  $ *SWRIT-o-û(OPEN/MAKc-*9)9(WRITEu-m-9 DISC WRITE ERRORF.PTҙ- ?TLOA-SP.WOR--AM9A9 A! 99 PM9 !% M9 A! # !?PAUS 9Z9.HD!\A\x29 k 2\xWITHIq!A 2 m.ASC!mZ}!M9.2HE!9wA!+AsC" $ Fs2WAR-   ! ? NOT DEFINED -- CONTINUING... 9DBU>..DEBU.P:9- COMPILING --> +As C k SP.FINĊ.Z-.A9.:AAM9 !4HE!Aw!DUM"s "sk P!Ok P!OM!9vCAS"(DO-CASESi"""s"E(CASEu""*s"}©"|©"E OҰ"E(ECASE"" o gEDO-CASEӳ" "CAS" "9ECAS SP.NUMBE.99[ P-s P 9E.29INTERPRE/.9RA 9 ! ! /!SCAN/AHEAL/+XsPm 9 O+XsPsPm 999"k "9xIEND-CASE"- M9 x!" OTHERWIS##DEBUG-VOY#v $kP:WORD:TYPżk  A" Is" M"$~ A"Z"$ A" U"$C A" C"$ A" V"$+-ONEXT.BLˊ/-A9-A,/9x!ATLOA0<xa)*9-xA9xA-x"0X/2x END TEXT COMPILATIONL(#9$ 9-xAxJ0-A9"09x!2A9&A9xAQmM9T 2!2 A" D"$?ISMUD/PRE#k P m9 S!Zk @m9 P!Zk NVLISi#:AA+$# " AMM!9NOi$MTHRդ$gO2DROа$-TEX$$A?DU$z 1$A-ABORT09-x ABORTING COMPILE AxERROR.STRIN1ERROR TXTNMESSAG71A9sL(| $L(#9$ F1o( *9 MSG # !*IF+Am9W(@s!W(@ k | L($!  MSG # SIGNOS1-SAVE.SYSTE2$IEXI%2@LOA%J!Ag?BINAR#%9TABL7%E 9OPOI%~CLc%~BEL%LÕ%Ræ%REMEMBEҵ%x  xxx 11  $  ENTER NEW SIGN-ON INFO -->  9_O9O  1P% 'TYPE 'BYE' AND SAVE UNDER CP/M COMMAND: # eg. A> SAVE # .COM BYE dLIN2m" !5      R1 TiE $ׄ!RR؄[jt  yB` q.`E !"_]`%K#18MbݠJh0dN*JBL"$(X*hAA(& "0:vOBjMC !+%I ,E-8EY )5\&U ۠N@+Ms 5$!,%.'Ēcѐ6GBB$2 8O*Ēq@F$ jZA v hB@"jmA p@` v}lJTO(YL&AuC )9StlM!  !!l&&ńt&脡 +:2{oMe0)*)JBkRf@ C E")Hª(S!aP)HE )U aU"@>\B,5C A!H2QR¨Yմ*UPXB(P _®!aUT&RЪfB+EQ @@ Hs T< *!"y4\ĮU(Aږ*b4|R nI  44H ]I6TASKSU Td%DA5%RPKEYTUT55( IRERRORԑ eDH9aQ 1.P5LBF0L'Xb!F#,hX8"uB&%%(O@  UV4Φ@80 U} !V *]dBHU @.="WЪBpU H VL*\BBmQR'PTCH2ŹWX*>qQ b  D,8M5 /U tH.TpXݰP@Z[А14G:XzfB%[ (EU (0]j (E W)]b@Q `_ JdqAp!\RgW rW0"@N'B)N"hO' $$G `R Rbذ $e+V@ @Pdi@L$h| W Up U@( . P$%9@)(( )8 D RiRT.t)H i%)h@j R)WjZv-!g6&0AClB`[DCunLçHb)@I'5.(] @e dB `6Y.P$ͼnHDfPK. ?-Tt1AC,!R,a0m  *|!aa;* )5C,;Tk6La p]j]i vׅԬ!2Ұ `*M  ` Rj V]*H_i U&*vQn5(-] 2SoQm(  5ۀڰp݀P@z -#IKd@m 9`40np@iX . 7Jeq8M!ZW2eo `7Z`4| ӀڐVh#`7$H+hee ` (0*H2*Y`j-0es B$6]u &ZP[d!Hu a w 1E' ,ksC.xep .e>ᗰ*]P!PEg]p˾w/cϾa2X_!0OhP CCo(e V2Edy=DChm x4a5U' ,LKne2 .݆Sħ6)A$mX  H$T""+RQp*.Q@ ^老`T\ _`Jd2 8^A$H,JVp%,(/`@MR*rZPM@K-h`hX@h@xW Ձ]#؁[0+[p+r[*6}@!`W S*_@ @(1RP\B&2` 6vWX")@AjUtmf 6^˾\XD5t 6аpC,Hm bI6- 6ـglm 6[H+ $- X6ւP1LA!Zw6ېY`А(H_(m ` !Cu ᷤ2ņP!LGgPpG@H5 ,`Q RPE = ސ Y+}@- +AL'XT7 td&P:U+Ut:~E+h@U 0;xRq@T" 'FoAj"z"z,f"'xB"z f1"(F"e8(&F[j"bf(*FI"zf@.*) F"g"!FVB* dw)'FPb**fP2"!QB2Jbdv'*$Fiê2zjg:"FmbB*,dH9&"FWCBzb$e2(*FBJ"|u0?$$"(FSZJrte "jb f*""Râb*d\=#       zÚbJf*Or*¤f1# Yrzzt|',*!&%ZZzr,d.'"FcAzJ"&E2bz $d&,PÚz`((F@|g())FR*jJdL> DB ..MLEN+80H ;; LENGTH ELSE DB ..MLEN+80H+P2 ENDIF IRP X, DB '&X' ENDM ORG $-1 DB ..LSTC+80H ENDM CSEG ORG 0 WORDGEN WORDGEN ,IMM END > Ab d)'B ,d,>'"ef:)F~**|u >* H"d6$)"TZJe'FhÚzg 5+tbzf`:*,"Djb*e*F@ꪚb d Fibzdd.+'FY*J"Dt+"GPlg5"'|jbzze@,')FMj‚bz|d>!) FGC*d>-"'JCb* d)'B ,d,>'"ef:)F~**|u >* H"d6$)"TZJe'FhÚzg 5+tbzf`:*,0800 ALLOT 03AD ANDD 0581 AT 079F BASE 069D BL 0CAC BLANK 074A BLK 0161 BRAN 0A9D BUILD 0590 CAT 0919 CFA 1335 CLD 0307 CMOVE 080C COMMA 09F8 COMP 077D CONT 0AD4 COUNT 02F3 CR 1129 CREAT 06A7 CSLL 05C7 CSTOR 078A CURR 08BD DDUP 0A59 DEC 0206 DIGIT 04F9 DMINU 05FB DOCOL 0640 DOCON 0AB9 DODOE 0AAD DOES 065A DOVAR 0732 DP 0137 DP0 07A8 DPL 04C0 DPLUS 012A DPUSH 0526 DROP 0B15 DTRAI 0540 DUP 0283 ENCL 0842 EQUAL 10CD ERROR 0152 EXEC 072A FENCE 0C7B FILL 129C FORTH 0472 FROMR 0890 GREAT 07F0 HERE 07CB HLD 0CBB HOLD 012B HPUSH 01F2 IDO 1C2B INITDP 0752 INN 08F9 LATES 0A0E LBRAC 0448 LEAVE 084E LESS 0909 LFA 013D LIT 04E3 MINUS 012C NEXT 0927 NFA 0624 NOOP 0FFE NXTBLK 0684 ONE 07D4 ONEP 0100 ORIG 03BF ORR 075B OUTT 0517 OVER 0CD3 PAD 192F PCR 0B48 PDOTQ 1923 PEMIT 093D PFA 0234 PFIND 190B PKEY 04B3 PLUS 18FD PQTER 055C PSTOR 097F QCOMP 0965 QERR 09AE QPAIR 02E6 QTERM 0CF3 QTLOAD 0C10 QUERY 089E ROT 0128 RPP 0419 RPSTO 0486 RR 0431 SEMIS 08AE SPACE 03E5 SPAT 03F4 SPSTO ****************** FORTH COMPILER GEN *********************** ( TRANSFERRED FROM FORTH BLKS DISK ) ( SCREENS 4-7 ERROR MESSAGES ) ( ERROR MESSAGES ) EMPTY STACK DICTIONARY FULL ISN'T UNIQUE DISC RANGE ?? FULL STACK DISC ERROR !! 0795 STATE 05B8 STORE 0834 SUBB 0533 SWAP 06F4 SZERO 1C27 TASK 054E TDUP 0694 THREE 0707 TIB 0573 TOGGL 045C TOR 068C TWO 07E1 TWOP 0AE7 TYPE 0870 ULESS 0126 UP 0359 USLAS 0324 USTAR 0740 VOCL 071F WARN 0712 WIDTH 0D18 WORD 1322 WRM 01D6 XDO 01 FORTH COMPILER DISKETTE 01/05/83 ( ERROR MESSAGES ) COMPILATION ONLY, USE IN DEFINITION EXECUTION ONLY CONDITIONALS NOT PAIRED DEFINITION NOT FINISHED IN 8F XLOOP 03D2 XORR 01C9 XPLOO 0179 ZBRAN 048D ZEQU 067C ZERO 04A1 ZLESS ARN 0712 WIDTH 0D18 WORD 1322 WRM 01D6 XDO 0107E1 TWOP 0AE7 TYPE 0870 ULESS 0126 UP 0359 USLAS 0324 USTAR 0740 VOCL 071F WARN 0712 WIDTH 0D18 WORD 1322 WRM 01D6 XDO 01PROTECTED DICTIONARY USE ONLY WHEN LOADING OFF CURRENT EDITING SCREEN DECLARE VOCABULARY OUTSIDE ALLOCATED FILE SPACE ( FORTH COMPILER GENERATION -- 4THCOMP 01/03/83 ) ' TASK FENCE ! FORTH DEFINITIONS FORGET TASK 99 LOAD FORTH DEFINITIONS ( ASSEMBLER ) 171 LOAD ( # PROCESSING ) 61 LOAD ( 2HEX, 4HEX, ?PAUSE, DUMP) 69 LOAD ( CASE words) 66 LOAD ( NVLIST ) 105 LOAD ( POLYFORTH TO FIG FORTH CONVERSION ) 59 LOAD ( REMEMBER, SAVE) 72 LOAD ( SLIST PICK, ?PICK, .S, BYE) 172 LOAD ( PRINTER ROUTINES ) 180 LOAD ( CP/M INTERFACE ) 240 LOAD ( TEXT LOAD, TLOAD ) 205 LOAD ( ERROR MESSAGES FROM CP/M FILE ) 57 LOAD ( SAVE.SYSTEM COMMAND ); WORDGEN.INC --- FORTH HEADER GENERATION IMM DEFL 40H ;; IMMEDIATE PRECEDENCE BIT WORDGEN MACRO WORD,P2 ..MLEN DEFL 0 ..LSTC DEFL 0 IRPC Y, ..MLEN DEFL ..MLEN+1 ;; COUNT NUMBER OF BYTES IN STRING ..LSTC SET '&Y' ENDM IFB R 16 BASE ! >R S->D <# # # R> IF # # ENDIF #> TYPE SPACE R> BASE ! ; --> ( WITHIN, 2HEX, 4HEOP 0 RAM.PTR ! LOOP CR ." END COPY" CR ; : DCLEAR CR ." CLEARING DISC B -- HIT RETURN TO CONTINUE" KEY DROP CR RAM 1024 32 FILL ( BLANK ) 499 250 DO RAM I 0 R/W LOOP ; ;S X ) ( Test for "n1" within "n2" and "n3") ( n1 n2 n3 --> f ) : WITHIN >R 1 - OVER < SWAP R> 1+ < AND ; ( Prints the character if within printing range) ( c --> ) : .ASC. 127 AND DUP BL 125 WITHIN 0= IF DROP 46 ( FORTH COMPILER GENERATION -- 4THCOMP 10/20/82 ) ' TASK FENCE ! FORTH DEFINITIONS FORGET TASK 99 LOAD FORTH DEFINITIONS ( ASSEMBLER ) 171 LOAD ( # PROCESSING ) 61 LOAD ( 2HEX, 4HEX, ?PAUSE, DUMP) 69 LOAD ( CASE words)  ( period) ENDIF EMIT ; ( Prints hex numbers: 2HEX = 2 digits, 4HEX = 4 digits) ( u --> ) : 2HEX 0 .H. ; : 4HEX 1 .H. ; --> ( DUMP routine 1/30/81 TJN) ( Dump memory in hex format ) ( ad 66 LOAD ( NVLIST ) 105 LOAD ( POLYFORTH TO FIG FORTH CONVERSION ) 59 LOAD ( REMEMBER, SAVE) 72 LOAD ( SLIST PICK, ?PICK, .S, BYE) 172 LOAD ( PRINTER ROUTINES ) 180 LOAD ( CP/M INTERFACE ) 240 LOAD ( TEXT LOAD, TLOAD ) 205 LOAD dr count --> ) ( Press: SPACE to pause dump, ESCAPE to exit dump. ) : DUMP CR OVER + SWAP DO ( new line) CR I 4HEX I 16 + I 2DUP SPACE DO ( one line of hex dump) I C@ 2HEX LOOP SPACE D( ERROR MESSAGES FROM CP/M FILE ) 57 LOAD ( SAVE.SYSTEM COMMAND ) ;S ( RE-WRITE COLD START VECTOR ) HEX 112D CONSTANT SIGNON ( SIGNON MESSAGE ) DECIMAL : SAVE.SYSTEM CR SIGNON 13 32 FILL ." ENTER NEW SIGN-ON INFO --> " 13O ( one line of ASCII dump) I C@ .ASC. LOOP ?PAUSE IF LEAVE ENDIF 16 ( offset) +LOOP CR CR ; ;S ( ROLL, DEPTH ) CODE (ROLL) D POP E A MOV D POP C L MOV B H MOV H PUSH 1 H LXI SP DAD B DUP 0 DO 95 EMIT LOOP 0 DO 08 EMIT LOOP QUERY 01 WORD HERE 1+ SIGNON HERE C@ CMOVE REMEMBER ." TYPE 'BYE' AND SAVE UNDER CP/M COMMAND:" CR ." eg. A> SAVE # .COM " CR ; : TASK ; ( CAP OF FORTH COMP ) ;S EGIN A DCR 0= NOT WHILE H INX M C MOV E M MOV C E MOV H INX M B MOV D M MOV D B MOV REPEAT B POP D PUSH NEXT JMP C; : DEPTH S0 @ SP@ - 2 / 1 - ; : ROLL ?DUP I ( New Fig Forth system load block 2/4/82 NAA) 99 LOAD FORTH DEFINITIONS ( ASSEMBLER ) ( 60 LOAD new -FIND word ) 171 LOAD ( # PROCESSING ) 61 LOAD ( 2HEX, 4HEX, ?PAUSE, DUMP) 69 LOAD ( CASE words) ( 7F DUP DEPTH 2 - SWAP U< 1 ?ERROR (ROLL) THEN ; ( ROLL TEST PROGRAM ) ( count --> ) : ROLL-TEST DUP 0 DO DUP >R ROLL CR .S R> LOOP DROP CR ; : NUM->STACK 9 8 7 6 5 4 3 2 1 ; : TE1 LOAD ?FREE, MYSELF) 66 LOAD ( NVLIST ) 149 LOAD ( TEXT LINE EDITOR, ALA BILL RAGSDALE ) 105 LOAD ( POLYFORTH TO FIG FORTH CONVERSION ) 59 LOAD ( REMEMBER, SAVE) 72 LOAD ( SLIST PICK, ?PICK, .S, BYE) 126 LOAD ( SOURCE, ST1 9 ROLL-TEST ; : TEST2 3 ROLL-TEST ; : TEST3 5 ROLL-TEST ; ( New VLIST word to print dictionary 2/24/81 TJN ) VOCABULARY DEBUG-VOC IMMEDIATE DEBUG-VOC DEFINITIONS ( hides internal DECODE) 172 LOAD ( PRINTER ROUTINES ) ;S ( REMEMBER, EMPTY words 2/5/81 TJN ) ( The next word must be typed before saving image in CP/M) : REMEMBER [COMPILE] FORTH DEFINITIONS ( Now save current pointers inDebug words) ( Prints word type: Colon, Variable, Constant, etc.) : P:WORD:TYPE SPACE DUP PFA CFA @ ( NFA --> NFA ) DO-CASES DUP PFA CFA 2 + CASE 77 ( Machine code) ECASE ' PAD CFA @ CASE BL ( colon word) "origin" TABLE ) HERE FENCE ! ( protect current DP ) LATEST 12 +ORIGIN ! ( top NFA ) HERE 28 +ORIGIN ! ( FENCE ) HERE 30 +ORIGIN ! ( DP ) VOC-LINK 32 +ORIGIN ! ( ECASE ' DP CFA @ CASE 85 ( User variable) ECASE ' 1 CFA @ CASE 67 ( Constant) ECASE ' PREV CFA @ CASE 86 ( Variable) ECASE ' FORTH CFA @ CASE 68 ( DOES> word ) ECASE  VOC-LINK) DP @ 256 / BASE @ >R DECIMAL CR CR ." Save blocks = " . CR CR R> BASE ! ; ;S : EMPTY CR CR ." Restarting Forth to EMPTY dictionary!" CR COLD ; ( NEW "-FIND" WORD TJN 1/28/81 ) : -NFIND B OTHERWISE 63 ( ? unkown word) END-CASES EMIT ( output character) 2 SPACES ; --> ( New VLIST cont.) ( Print SMUDGE and PRECEEDENCE bits ) ( NFA --> NFA ) : SMUD/PREC CR SPACE DUP C@ DUP 32 ANL WORD HERE CONTEXT @ @ (FIND) DUP 0= IF DROP LATEST CONTEXT @ @ - IF HERE LATEST (FIND) ELSE 0 ENDIF ENDIF ; : NEW ( CHANGE THE "-FIND" COMMAND ) ' -NFIND 2 - ' -FIND ! ' ;S 2 - ' -FIND 2 + ! ; D IF 83 ( S ) ( smudge bit set) ELSE BL ENDIF EMIT SPACE 64 AND IF 80 ( P ) ( preceedence bit set) ELSE BL ENDIF EMIT SPACE ; --> ( New VLIST cont.) ( ?PAUSE, 2HEX, 4HEX, DUMP 1/30/80 TJN) ( TEST KEYBOARD: PAUSES ON SPACE KEY, "F"=TRUE FOR ESCAPE KEY) : ?PAUSE ?TERMINAL DUP ( --> f ) IF DROP KEY DUP BL = IF DROP KEY ENDIF  FORTH DEFINITIONS ( Prints current vocabulary words: flags - type - CFA name ) : NVLIST CONTEXT @ @ CR DEBUG-VOC ( --> ) BEGIN SMUD/PREC P:WORD:TYPE DUP PFA 4HEX DUP ID. PFA LFA @ DUP ( next word a     ddress) 0= ( end of dict) ?PAUSE ( operator stop?) OR UNTIL DROP CR CR ; FORTH ;S ( "CASE" word definitions 2/3/81 TJN) 0 VARIABLE vCASE ( case value) CODE (DO-CASES) H POP v 27 = IF BYE THEN ." Chicken?" CR ; ( Adjust end of memory 'EM' 2/25/81) ( The followong constants must match the values in the kernel) 1024 CONSTANT KBBUF ( bytes per disk buffer) 1028 CONSTANT TKBBUF ( CASE SHLD NEXT JMP C; CODE (CASE) D POP vCASE LHLD L A MOV E CMP 0= IF H A MOV D CMP 0= IF B INX B INX NEXT JMP ENDIF ENDIF B LDAX C ADD A C MOV CS IF B INR ENDIF NEXT JMP C; CODE (ECASE) B LDAX total bytes per disk buffer) 2 CONSTANT NSCR ( number of screens ) 64 CONSTANT US ( USER storage size ) 160 CONSTANT RTS ( Return stack + terminal buf storage) 0 VARIABLE NBUF ( number of disk buffers) 0 VARIAA L MOV B INX B LDAX A H MOV H PUSH B POP NEXT JMP C; --> ( DO-CASES, CASE, ECASE, END-CASES ) : DO-CASES COMPILE (DO-CASES) 5 ; IMMEDIATE : CASE COMPILE (CASE) HERE 0 , 6 ; IMMEDIATE : ECASBLE EM ( end of memory address) 0 VARIABLE BUF1 ( address of first disk buffer) 0 VARIABLE INIT-R0 ( initial location of Return stack) 0 VARIABLE INIT-S0 ( initial location of Parameter stack) --> ( Adjust end of memE 6 ?PAIRS COMPILE (ECASE) 0 , HERE OVER - SWAP ! HERE 2 - ; IMMEDIATE : END-CASES BEGIN ?STACK DUP 7 U< 0= WHILE HERE SWAP ! REPEAT 5 - 19 ?ERROR ; IMMEDIATE : OTHERWIory 'EM' ) : NBUF! NSCR 1024 * KBBUF / NBUF ! ; : BUF1! EM @ TKBBUF NBUF @ * - BUF1 ! ; : INIT-R0! BUF1 @ US - INIT-R0 ! ; : INIT-S0! INIT-R0 @ RTS - INIT-S0 ! ; ( Enter new memory size for Forth) ( new:memSE ; IMMEDIATE ;S ( Misc. words: ?FREE, MYSELF ) ( Displays the amount of bytes remainning in dictionary ) ( from HERE to bottom of stack @S0 ) : ?FREE BASE @ 10 BASE ! S0 @ HERE - CR CR U. ." Bytes free in dictionary" ory:size --> ) ( Note: The +ORIGIN values depend on the Forth kernel ) ( Adjusts: Disk bufffers, User variable area, Return stack, ) ( Terminal Input Buffer and Parameter stack. ) : NEW-EM DUP EM ! ' LIMIT ! NBUF! BUF1! I CR CR BASE ! ; ( MYSELF: recursion jump back to the current definition) CODE (MYSELF) B LDAX A L MOV B INX B LDAX A B MOV L C MOV B INX B INX NEXT JMP C; : MYSELF COMPILE (MYSELF) LATEST PFA CFA , ; NIT-R0! INIT-S0! INIT-R0 @ DUP 16 +ORIGIN ! DUP 20 +ORIGIN ! DUP 38 +ORIGIN ! 40 +ORIGIN ! INIT-S0 @ DUP 18 +ORIGIN ! 22 +ORIGIN ! BUF1 @ ' FIRST ! NBUF @ ' #BUFF ! COLD ; ( Forth Test words --- DO ) : D1  IMMEDIATE ( Stack list words: ?PICK PICK .S, BYE SLIST ) ( Pick number "n" from the parameter stack ) ( nx --> n1 f ) : ?PICK 2 * SP@ + DUP @ SWAP 2+ S0 @ > DUP IF ( not enough on stack) SWAP DROP THEN 40010 40000 DO I U. LOOP ; : D2 20 10 DO I . LOOP ; : D3 -20 -3 DO I . LOOP ; : D4 -20 -3 DO I . 2 +LOOP ; : D5 -20 -3 DO I . -1 +LOOP ; : D6 -3 -20 DO I . -1 +L ; ( Pick a number from the stack, Error #1 if not found) : PICK ?PICK 1 ?ERROR ; ( Prints stack contents without cr/lf's) : .S 11 ( # of values to print) DUP >R ( save count) 1 DO I ?PICK IF LEAVE ELSE . THEN LOOPOOP ; : D7 -3 -20 DO I . 1 +LOOP ; HEX : D8 8004 7FFB DO I . LOOP ; DECIMAL : TEST CR D1 CR D2 CR D3 CR D4 CR D5 CR D6 CR D7 CR D8 CR ; --> ( Forth benchmark program --- V1-BENCH )  R> ?PICK IF ." << " ELSE DROP THEN ; : BYE CR ." Insert CP/M boot disk and press ESCape key" KEY CR 27 = IF BYE THEN ." Chicken?" CR ; ;S : SLIST CR CR .S CR ; ( Console display words: TAB, ASC, >>A  0 VARIABLE X : BELL 7 EMIT ; : V1-BENCH BELL 0 X ! 30000 0 DO X @ 100 + X SWAP ! LOOP BELL ; ( Forth TRACE routines ) ( Tab to position "n" on current line: 0 to 79) ( n --> ) : TAB OUT @ - DUP 0 > IF SPACES ELSE DROP THEN ; ( Outputs ASCII character "c", "n" number of times to console) : ASC ( n c --> ) SWAP 0 DO DUP EMIT LOOP  2/27/81 TJN) ( ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; ; F O R T H T R A C E ; ; ; ;  DROP ; ( Make a literal out of the ASCII character following ) ( Works in either compile or execution modes. >>A T ) : >>A BL WORD HERE 1+ C@ [COMPILE] LITERAL ; IMMEDIATE ;S ( Misc. words: SHOW, COPY, BYE  P R O G R A M Ver 1.0 ; ; ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ) ( 126 LOAD ) DEBUG-VOC DEFINITIONS 0 VARIABLE TLCHAR ( Last Trace Level Character ) 0 VARIABLE2/24/81 TJN) ( List a group of blocks from n1 thru n2) ( n1 n2 --> ) : SHOW 1+ SWAP 3 / 3 * DO I TRIAD ?PAUSE IF LEAVE THEN 3 +LOOP ; ( Copy block x to block y; block x remains unchanged) : COPY B/SCR * OFFSET @ +  TMODE ( Trace mode: 0=continious, 1=step) 0 VARIABLE XDP ( *** ) 0 VARIABLE XHLD ( save values) 0 VARIABLE XBASE ( *** ) 0 VARIABLE NBASE ( Bases ) 85 89 THRU ( Trace words continued) ( Get level number of Return Stack: 0 to ( x y --> ) SWAP B/SCR * B/SCR OVER + SWAP DO DUP FORTH I BLOCK 2 - ! 1+ UPDATE LOOP DROP FLUSH ; ( Returns control back to CP/M operating system) : BYE CR ." Insert CP/M boot disk and press ESCape key" KEY CR  9) ( addr --> n ) : RSLEVEL R0 @ SWAP - 2 / 3 - 99 MIN ; ( Store Return stack level from ASCII character on stack) : STORE-LEVEL DUP TLCHAR ! >>A 0 - 2 * R0 @ 6 - SWAP - XRP 6 + ! ; ( --> n ) (      Print trace legend on console ) ( --> ) : PRINT-LEGEND CR CR ." TLV RS IP CFA Name " ." Stack contents (top <--)" CR 63 >>A - ASC CR ; ( Trace words continued) : TEST-CHAR DO-CASES ( c1 c1 -EX 00 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 F9 1MI SPHL E3 1MI XTHL EB 1MI XCHG 27 1MI DAA 2F 1MI CMA 37 1MI STC 3F 1MI CMC 80 2MI ADD -> c2 ) 27 CASE DROP >>A # ( ESCape ) ECASE >>A S CASE 1 TMODE ! ( Step ) ECASE >>A C CASE 0 TMODE ! ( Trace ) ECASE >>A R CASE 0 XRP 8 + ! ( Run ) ECASE 88 2MI ADC 90 2MI SUB 98 2MI SBB A0 2MI ANA A8 2MI XRA B0 2MI ORA B8 2MI CMP 09 3MI DAD C1 3MI POP C5 3MI PUSH 02 3MI STAX 0A 3MI LDAX 04 3MI INR 05 3MI DCR 03 3MI INX 0B 3MI DCX C7 3MI RST D3  OTHERWISE DROP TLCHAR @ ( last char ) END-CASES ; ( Get trace level: from operator ) ( -- f ) ( f=0 to abort) : GET-TLEVEL ( 0 ... ? = level, ESCape = abort ) 13 EMIT ( cr) ." (" KEY DUP DUP >>A 0 >>A ? WITHIN4MI 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 2A 5MI LHLD 32 5MI STA 3A 5MI LDA C4 5MI CNZ CC 5MI CZ D4 5MI CNC DC 5MI CC IF STORE-LEVEL ( 0 thru ? ) ELSE TEST-CHAR THEN DUP EMIT ( echo char) >>A # - ; ( Trace words continued) ( Print one trace line: RS level, IP, CFA, name, stack values) : PRINT-TLINE OUT @ IF CR CR THEN ." (? E4 5MI CPO EC 5MI CPE F4 5MI CP FC 5MI CM CD 5MI CALL --> ( Fig-Forth 8080 Assembler ) C0 1MI RNZ C8 1MI RZ D0 1MI RNC D8 1MI RC E0 1MI RPO E8 1MI RPE F0 1MI RP F8 1MI RM C9 1MI RET C3 5MI J) " XRP @ RSLEVEL 2 .R 2 SPACES ( print Ret Stack level) XRP 2+ @ DUP 4HEX 1 SPACES ( print IP ) @ DUP 4HEX 1 SPACES ( print CFA ) TRAV ( do word search) IF ID. ELSE ." ??? " DROP MP C2 CONSTANT 0= D2 CONSTANT CS E2 CONSTANT PE F2 CONSTANT 0< : NOT 8 + ; : MOV 8* 40 + + C, ; : MVI 8* 6 + C, C, ; : LXI 8* 1+ C, , ; : ENDIF 2 ?PAIRS HERE SWAP ! ; : IF C, HERE 0 , 2 ; : TH THEN 39 TAB ?STACK ( test stack) .S ( print stack contents) ; ( Trace words continued) ( Debug routine comes here to print on trace line and input new trace level from operator) ( --> ) : (DOTRACE) HERE XDP ! HLD @EN [COMPILE] ENDIF ; : ELSE 2 ?PAIRS 0C3 IF ROT SWAP ENDIF 2 ; : BEGIN HERE 1 ; : UNTIL SWAP 1 ?PAIRS C, , ; : AGAIN 1 ?PAIRS 0C3 C, , ; : WHILE IF 2+ ; : REPEAT >R >R AGAIN R> R> 2 - ENDIF ; DECIMAL XHLD ! 200 ALLOT ( move PAD) BASE @ XBASE ! NBASE @ BASE ! PRINT-TLINE TMODE @ ?TERMINAL OR IF GET-TLEVEL ELSE 1 THEN CR XDP @ DP ! XHLD @ HLD ! XBASE @ BASE ! IF TRACE-NEXT ( continue tracing) TH FORTH DEFINITIONS ;S ( Simple example of call High Label Forth words from CODE ) CODE >LO B H MOV C L MOV B POP PCHL C; ( Test #1 ) CODE TEST1 B PUSH HERE 6 + B LXI NEXT JMP FORTH ] CR ." I'am ok " EN CR ." Trace Aborted by operator" CR QUIT ; ' (DOTRACE) CFA XRP 10 + ! ( patch address) ( Main TRACE routine ) : STEP/TRACE R> DROP ( tmode --> ) ( name ) BASE @ NBASE ! ( save BASE ) TMODE ! CR >LO [ ASSEMBLER NEXT JMP C; --> ( Definition words for CODE -> HLF and HLF -> CODE ) ASSEMBLER DEFINITIONS ( CODE to High Level Forth words ) : >HI B PUSH HERE 6 + B LXI NEXT JMP [COMPILE] FORTH  ( and mode ) [COMPILE] ' ( search for word) CFA DEBUG-VOC PRINT-LEGEND 48 TLCHAR ! TEXECUTE ( do the trace) ;TRACE ( end trace) CR ." Trace completed" CR ; FORTH DEFINITIONS ( Examples:  [COMPILE] ] ; IMMEDIATE FORTH DEFINITIONS ( High Level Forth words ) CODE (>LOW) B H MOV C L MOV B POP PCHL C; : >LOW COMPILE (>LOW) [COMPILE] ASSEMBLER [COMPILE] [ ; IMMEDIATE  STEP name -or- TRACE name ) : STEP DEBUG-VOC 1 STEP/TRACE ; ( Step tracing ) : TRACE DEBUG-VOC 0 STEP/TRACE ; ( Continous tracing ) FORTH ( Fig-Forth 8080 assembler ) VOCABULARY ASSEMBLER IMMEDIATE ' ASSEMBLER CFA ' --> ( Test #2 & #3 ) 255 CONSTANT PANEL ( Front panel switch port # ) ( Test Program #2 ) CODE TEST2 >HI CR ." I'AM OK " CR >LOW NEXT JMP C; ( Test program #3 ) CODE TEST2 0 A MVI  ;CODE 8 + ! ( PATCH ";CODE" IN NUCLEUS) : CODE ?EXEC CREATE [COMPILE] ASSEMBLER !CSP ; IMMEDIATE : C; CURRENT @ CONTEXT ! ?EXEC ?CSP SMUDGE ; IMMEDIATE : LABEL ?EXEC 0 VARIABLE SMUDGE -2 ALLOT [COMPILE] ASSEMBLER !CSP ;  PANEL OUT >HI CR ." Enter a Key: " KEY CR SWAP >LOW H POP L A MOV PANEL OUT NEXT JMP C; --> ( PolyForth to Fig Forth conversion words) : NOT 0= ; ( Loads a group of disk blocks ) ( n1 n2 --> ) : THRU 1+ IMMEDIATE : 8* DUP + DUP + DUP + ; ASSEMBLER DEFINITIONS 4 CONSTANT H 5 CONSTANT L 7 CONSTANT A 6 CONSTANT PSW 2 CONSTANT D 3 CONSTANT E 0 CONSTANT B 1 CONSTANT C 6 CONSTANT M 6 CONSTANT SP : 1MI  SWAP DO I LOAD LOOP ; : 2DROP DROP DROP ; ( Dummy text match word) ( addr1 count addr2 --> true ) : -TEXT 2DROP DROP 1 ( TRUE flag ) ; : ?DUP -DUP ; : 1- 1 - ; : 2- 2 - ; : EXIT R> DROP ;S ; --> C@ C, ; : 2MI C@ + C, ; : 3MI C@ SWAP 8* + C, ; : 4MI C@ C, C, ; : 5MI C@ C, , ; --> ( Fig-Forth 8080 assembler ) H ( Fig Forth conversion words) ( Flushes all blocks to disk and loads last Edited screen ) : @LOAD FLUSH SCR @ LOAD ; ( Test block for binary - true = binary) ( block# --> flag ) : ?BINARY DROP 0 ( false ) ; ( Create      a table named xxxx ) ( table:addr count --> ) ( xxx) : TABLE CREATE SMUDGE 0 DO , LOOP ; --> ( Fig Forth conversion words - Console = HAZELTINE 1500 ) ( Position cursor ) ( x y --> ) : POS 126 EMIT 17 EMIT NT.) : CHOLE MCOL ?DUP IF GXCOL SWAP 0 DO DUP DUP 1+ C@ SWAP C! 1+ LOOP BL SWAP C! THEN ; : +SCAN MCOL 1+ DCNT ! BEGIN MCOL 0= IF DROP EXIT THEN DUP GXCOL C@ BL = = WHILE DWRD @ IF CHOLE -1 DSWAP EMIT EMIT ; ( CLEAR SCREEN ) ( --> ) : CLS 126 EMIT 28 EMIT ; ( Ring Bell on console) ( --> ) : BELL 7 EMIT ; ( Left and Right cursor commands) : LC 8 EMIT ; ( Left cursor ) : RC 16 EMIT ; ( RCNT +! DCNT @ 0= IF DROP EXIT THEN ELSE 1 XCOL +! THEN REPEAT DROP ; : -SCAN BEGIN @XCOL CMIN = IF DROP EXIT THEN DUP GXCOL C@ BL = = WHILE -1 XCOL +! REPEAT DROP ; : NLINE LB> >LB CMIN XCOL ! XYight cursor ) ;S ( CRT SCREEN EDITOR LOAD BLOCKS Fig Forth Version ) ( ************************* ) ( * * ) ( * SCREEN EDITOR * ) ( * * ) ( * DATE: 3/2/81 * ) ( POS ; ( SCREEN EDIT - CONT.) : RUB BS IMODE @ NOT IF BL CSTORE LC ELSE CHOLE 1DLINE THEN ; : SP-> DUP 125 ( rubout or tidla ) > IF RUB DROP ELSE IMODE @ IF MHOLE THEN CSTORE 1 XCOL* BY. TOM NEWMAN * ) ( * * ) ( ************************* ) VOCABULARY NEDITOR-VOC IMMEDIATE DECIMAL NEDITOR-VOC DEFINITIONS 109 118 THRU ( Load remainning words ) ( SCREEN EDITOR - CONT.) 0 VAR +! MCOL 0< IF BS BELL THEN THEN ; : ^T 1 DWRD ! 0 +SCAN 1 +SCAN 0 DWRD ! 1DLINE ; : ^M CMIN XCOL ! ^X ; : ^U CMIN XCOL ! XYPOS ; : ^I BELL ; ( *** ) : ^L BELL ; : ^P BELL ; IABLE XCOL 0 VARIABLE IMODE 0 VARIABLE DWRD 0 VARIABLE DCNT 70 CONSTANT CMAX 7 CONSTANT CMIN 119 CONSTANT MENU : @XCOL XCOL @ ; : GXCOL @XCOL 6 - PAD + ; : MCOL CMAX @XCOL - ; ( ( *** ) : ^V BELL ; ( SCREEN EDIT - CONT.) : ^Z 15 NLINE ; ( *** ) : ^N MLINE ; : ^S BS ; ( *** ) : ^Y CLINE ; : ^H MHOLE ; ( *** ) : ^W 0 NLINE ; : ^K DEOL ; (  SCREEN WORDS - CONT.) : AST 42 EMIT ( * ) ; : *'S 0 DO AST LOOP ; ( Prints '*' ) ( count --> ) : XPOS PAD C@ 4 + POS ; : XYPOS @XCOL XPOS ; : >LB 15 AND DUP PAD C! SCR @ (LINE) PAD 1+ SWAP CMOVE *** ) : ^G CHOLE 1DLINE ; : ^O IMODE @ -1 XOR IMODE ! BELL 50 0 POS IMODE @ IF ." -> INSERT MODE <-" ELSE 17 SPACES THEN XYPOS ; : ^D MCOL IF 1 XCOL +! RC ELSE BELL THEN ; : ^F 0 +SCAN 1 +SCAN XYPO ; : LB> PAD 1+ PAD C@ SCR @ (LINE) DROP 2DUP 64 SWAP -TEXT ( compare new with the old line) IF ( not the same) 64 CMOVE UPDATE ELSE ( no changes) 2DROP THEN ; ( SCREEN EDITIOR - DISPLAY LINES / BLOCK) S ; : ^A 0 -SCAN 1 -SCAN 0 -SCAN 1 +SCAN XYPOS ; : ^B CMAX XCOL ! 1 -SCAN 0 +SCAN XYPOS ; ( SCREEN EDIT - CONT.) : ^Q 45 0 POS ." Type 'Y' to CLEAR block: " KEY DUP EMIT 89 = IF ( SCR @ BLOCK 1024 BLA : DLINE 1 XPOS PAD C@ 2 .R 2 SPACES AST SPACE PAD 1+ 64 TYPE SPACE AST XYPOS ; ( DISPLAY SCREEN) : DSCRN CLS ." Screen: " SCR @ . CR CR CMIN XCOL ! 5 SPACES 68 *'S CR 5 SPACES AST 66 SPACES ASTNKS ) DSCRN UPDATE ELSE 45 0 POS 30 SPACES XYPOS THEN 0 IMODE ! ; : ^J LB> @XCOL PAD C@ SCR @ MENU SCR ! DSCRN KEY DROP SCR ! DSCRN >LB XCOL ! XYPOS IMODE @ IF 0 IMODE ! ^O THEN ; ( Create t CR 16 0 DO I >LB DLINE LOOP CR 5 SPACES AST 66 SPACES AST CR 5 SPACES 68 *'S 0 >LB XYPOS ; ( SCREEN EDITOR - CONT.) : BS @XCOL CMIN = NOT IF -1 XCOL +! LC ELSE BELL THEN ; :able of control keys ) ' BELL DUP DUP DUP DUP ' ^Z ' ^Y ' ^X ' ^W ' ^V ' ^U ' ^T ' ^S ' ^R ' ^Q ' ^P ' ^O ' ^N ' ^M ' ^L ' ^K ' ^J ' ^I ' ^H ' ^G ' ^F ' ^E ' ^D ' ^C ' ^B ' ^A ' BELL 32 TABLE CNTRL-KEYS ( SCREEN EDIT - 'EDIT' CSTORE DUP EMIT GXCOL C! ; ( Store a character) : 1DLINE GXCOL MCOL 1+ TYPE @XCOL XPOS ; : ?CUR IF LB> >LB ELSE BELL DROP THEN XYPOS ; : ^E PAD C@ 1- DUP 0 < NOT ?CUR ; : ^X PAD C@ 1+ DUP 16  ) ( Full Screen EDITOR ) ( screen# --> ) : EDIT NEDITOR-VOC SCR ! 0 DUP DWRD ! IMODE ! DSCRN BEGIN KEY DUP 27 ( ESCape key) - WHILE DUP BL < NOT IF SP-> ( printable or DELete chars. ) < ?CUR ; : GET-NEW-SCR LB> SCR +! ( INC/DEC ) DSCRN ; : ^C 1 GET-NEW-SCR ; ( *** ) : ^R -1 GET-NEW-SCR ; ( SCREEN EDIT - CONT.) : MHOLE MCOL ?DUP IF CMAX 6 - PAD + BEGIN DUP DUP 1- C@ SWAP C! 1- SWAP  ELSE 2 * ' CNTRL-KEYS + @ CFA EXECUTE THEN REPEAT DROP LB> CLS ; : ED SCR @ EDIT ; FORTH ( just for show ) ------------ Fig Forth Editor Commands (2/10/81) ------------ Right ........... Cn1- ?DUP WHILE SWAP REPEAT BL SWAP C! 1DLINE THEN ; : DEOL GXCOL MCOL 1+ BLANKS 1DLINE ; : MLINE PAD C@ LB> CMIN XCOL ! 15 BEGIN DUP >R OVER - WHILE I DUP 1- >LB PAD C! XYPOS 1DLINE LB> R> 1- trl D Next word ........ Cntrl F Left ........... " S Last word ........ " A Up .............. " E End of line ...... " B Down ............ " X Beg of line ...... " U Top of block ....  REPEAT R> DROP PAD C! XYPOS DEOL ; : CLINE PAD C@ LB> CMIN XCOL ! DUP BEGIN DUP 15 - WHILE DUP DUP 1+ >LB PAD C! XYPOS 1DLINE LB> 1+ REPEAT PAD C! XYPOS DEOL LB> >LB XYPOS ; ( SCREEN EDIT - CO" W Get next screen .. " C End of block .... " Z Get last screen .. " R Next Line ....... RETURN Text chars ....... SPACE - } Delete to EOL .... Cntrl K Insert blank ....      Cntrl H Insert line ...... " N Scrunch char .... " G Delete line ...... " Y Delete word ..... " T Clear screen ..... " Q Delete char ..... RUBOUT Toggle Insert .... " O Exit Editor ... -->" 2+ DUP @ . SPACE ; ( Print quoted string here) : DO-QUOTE DROP ( NFA) 2+ DUP C@ DUP OUT +! ?CR OVER 1+ + SWAP ( ." ) 46 EMIT 34 EMIT SPACE COUNT TYPE ( print string) 34 EMIT 2 SPACES 2 - ; --> ( S.. ESC Display menu ..... " J ( Simple example of calling High Level Forth words from CODE ) CODE >LO B H MOV C L MOV B POP PCHL C; ( Test #1 ) CODE TEST1 B PUSH HERE 6 + B LXI NEXT JMP FORTH ] CR OURCE and DECODE cont.) ' BRANCH NFA CONSTANT 'BRANCH ( Get the "name field ) ' 0BRANCH NFA CONSTANT '0BRANCH ( addresses" of special) ' ;S NFA CONSTANT ';S ( case words. ) ' (.") NFA CONSTANT '(.") '." I'am ok " CR >LO [ ASSEMBLER NEXT JMP C; 121 124 THRU ( Definition words for CODE -> HLF and HLF -> CODE ) ASSEMBLER DEFINITIONS ( CODE to High Level Forth words ) CODE (>HI) B H MOV C L MOV B POP H PUSH LIT NFA CONSTANT 'LIT ' (CASE) NFA CONSTANT '(CASE) ' (ECASE) NFA CONSTANT '(ECASE) ' (+LOOP) NFA CONSTANT '(+LOOP) ' (LOOP) NFA CONSTANT '(LOOP) --> ( SOURCE and DECODE cont.) ( Print name or hex byte if unknown)  NEXT JMP C; : >HI ' (>HI) CALL [COMPILE] FORTH ] ; IMMEDIATE FORTH DEFINITIONS ( High Level Forth to CODE words ) CODE (>LOW) B H MOV C L MOV B POP PCHL C; : >LOW COMPILE (>LOW) [COMPILE] ASSEMBLER  ( CFAddr --> ) : NAMETYPE TRAV OVER SWAP ?CR 0 BOFFSET ! IF DO-CASES '0BRANCH CASE .BRAN ECASE 'BRANCH CASE .BRAN ECASE '(CASE) CASE .BRAN EC [COMPILE] [ ; IMMEDIATE ( Test #2 & #3 ) 255 CONSTANT PANEL ( Front panel switch port # ) ( Test Program #2 ) CODE TEST2 >HI CR ." I'AM OK " CR >LOW NEXT JMP C; ( Test pASE '(ECASE) CASE .ECASE ECASE '(+LOOP) CASE .BRAN ECASE '(LOOP) CASE .BRAN ECASE --> ( Cases continued on next block ) ( SOURCE and DECODE cont.) ( Casrogram #3 ) CODE TEST3 0 A MVI PANEL OUT >HI CR ." Enter a Key: " KEY CR SWAP >LOW H POP L A MOV PANEL OUT NEXT JMP C; ( Test #4 ) CODE TEST4 PANEL IN 1 ANI 0= ( test switch #1 ) IF es continued) '(.") CASE DO-QUOTE ECASE 'LIT CASE DROP 2+ DUP @ . SPACE ECASE ';S CASE ." ;" 2DROP 0 ECASE OTHERWISE ID.  >HI CR ." Set panel switch #1 on" CR >LOW BEGIN PANEL IN 1 ANI 0= NOT UNTIL >HI CR ." Thank you" CR >LOW THEN 1 A MVI PANEL OUT NEXT JMP C; ( Test #5 ) ( Inputs value  SPACE END-CASES ELSE 2DROP DUP C@ 35 EMIT 2HEX 1 - ( unknown word ) THEN ; --> ( SOURCE and DECODE program cont.) FORTH DEFINITIONS ( Types Source of word following) ( --> ) ( name ) : SOURCE DEBUG-VOCfrom panel switches and sends it to the console) ( Then waits for keyboard and sends it to the panel lights.) CODE TEST5 PANEL IN A L MOV H PUSH ( value to stack ) >HI SWAP EMIT KEY SWAP >LOW H POP  HEADTYPE BEGIN 2+ DUP @ NAMETYPE DUP 0= ?PAUSE OR UNTIL DROP 2CR ; ( Decodes the word following: with addresses) ( --> ) ( name ) : DECODE DEBUG-VOC HEADTYPE CR BEGIN 2+ L A MOV PANEL OUT NEXT JMP C; ( SOURCE and DECODE program 2/24/81 TJN) DEBUG-VOC DEFINITIONS 0 VARIABLE BOFFSET ( Branch offset value) : 2CR CR CR ; : ?CR OUT @ 60 > IF CR 3 SPACES THEN ;  CR DUP U. DUP @ NAMETYPE BRANCH? DUP 0= ?PAUSE OR UNTIL DROP 2CR ; FORTH ( PRINTER DRIVERS/SLOT #3 ) 3 CONSTANT #SLOT : BAUD/SLOT #SLOT 1144 + ; HEX : PROM/SLOT C000 #SLOT 100 * +  ( Get next from from input, return PFA) ( --> addr) : HEADTYPE 2CR ." : " [COMPILE] ' DUP NFA ID. 2 SPACES 2 - ; ( Print branch address if BOFFSET is non-zero) : BRANCH? BOFFSET @ ?DUP ( addr --> addr ) IF; : NOCR/SLOT 6F8 #SLOT + ; : VIDEO/SLOT 7F8 #SLOT + ; IMMEDIATE : 300BAUD ( SET 300 BAUD ) 40 BAUD/SLOT C! ; : 1200BAUD ( SET 1200 BAUD ) 10 BAUD/SLOT C! ; --> ( PRINTER DRIVERS ) CODE INIT ( INITIALIZE ) XSAVE STX, A0 # LDA,  OVER + ." -->" . THEN ; --> ( SOURCE and DECODE cont.) ( 'TRAV' looks thru the dictionary for a CFA match) ( CFAddr --> CFAddr false ) ( CFA --> NFAddr true ) : TRAV CONTEXT @ @ ( Returns TRUE if match found!) BEGIN PROM/SLOT JSR, XSAVE LDX, NEXT JMP, C; CODE VIDEO ( SET VIDEO ) VIDEO/SLOT LDA, 7F # AND, VIDEO/SLOT STA, NEXT JMP, C; CODE N/VIDEO ( TURN OFF ) VIDEO/SLOT LDA, 80 # ORA, VIDEO/SLOT STA, NEXT JMP, C; --> ( PRINTER DRIVERS )  DUP >R PFA CFA OVER = IF DROP R> 1 1 ELSE R> PFA LFA @ DUP 0= IF ( unknown word ) DROP 0 1 ELSE 0 THEN THEN UNTIL ; -->  : PRINT ( ENABLE PRINTER ) PROM/SLOT 7 + 36 ! 0 NOCR/SLOT C! ; : TUBE ( RE-INIT TUBE ) FD1B 38 ! FDF0 36 ! ; TUBE --> ( HI RES GRAPHICS TESTING ) HEX CODE GR ( GO TO GRAPHICS, 2ND PG ) C050 LDA, ( GRAPHICS )  ( SOURCE and DECODE cont.) ( BRANCH and 0BRANCH come here to print offset value) : .BRAN ID. ." [" 2+ DUP @ DUP BOFFSET ! ( offset) 0 .R ." ] " ; ( ECASE comes here: prints the End of Case address) : .ECASE ID. ." C055 LDA, ( 2ND PAG ) C057 LDA, C052 LDA, NEXT JMP, C; CODE TXT ( GO TO TEXT ) C054 LDA, C051 LDA, NEXT JMP, C; --> ( HI RES GRAPHICS ) HEX 00 VARIABLE MASK -2 ALLOT 01 C, 02 C, 04 C, 08 C, 10 C, 20 C, 40 C     , 80 C, 00 VARIABLE DOUBLE : GRAPH ( ENTER GRAPHICS ) 1B EMIT 33 EMIT 1B EMIT 1E EMIT DOUBLE @ IF 2 ELSE 1 THEN EMIT ; : DOT ( PRINT DOT ) DOUBLE @ IF ." *" ELSE ." ." THEN ; 00 VARIABLE ADDR : CR 0D EMIT 10 SPACES ; : LF 0 ( REPLACE ON LINE #-1, FROM PAD ) PAD 1+ SWAP -MOVE ; : P ( PUT FOLLOWING TEXT ON LINE-1 ) 1 TEXT R ; : I ( INSERT TEXT FROM PAD ONTO LINE # ) DUP A EMIT ; --> ( HI RES DRIVERS ) 00 VARIABLE REV ( REVERSE ) : 1LINE ( FROM-2, TO-1 ) CR GRAPH ( ENTER GRAPHICS ) LF 1+ SWAP DO I ADDR ! 7 0 DO ADDR @ C@ MASK I + C@ AND 0= 0= REV @ XOR IF DOT THEN SPACE DOUBLE @ IF SPACE THS R ; : TOP ( HOME CURSOR TO TOP LEFT OF SCREEN ) 0 R# ! ; --> ( SCREEN EDITING COMMAND ) : CLEAR ( CLEAR SCREEN BY NUMBER ) SCR ! 10 EN LOOP LOOP ; : 8LINES ( ACCEPT ON STACK ) ( BASE ADDRESS ) 2000 OVER + SWAP DO I DUP 27 + 1LINE 400 +LOOP ; ( PRINT GRAPHICS SCREEN ) : REVERSE 1 REV ! ; : NORMAL 0 REV ! ; : ?GRAPH ( SPECI 0 DO FORTH I EDITOR E LOOP ; : COPY ( DUPLICATE SCREEN-2, ONTO SCREEN-1 ) B/SCR * OFFSET @ + SWAP B/SCR * B/SCR OVER + SWAP DO DUP FORTH I BLOCK 2 - ! 1+ UPDATE LOOP DROP FLUSH ; FY GRAPH ) OPEN ( ASK FOR FILE AND OPEN ) ( BRING TO HEX 6000 ) 0 R.REC ! 8 0 DO 8IN DBUFF1 4000 400 I * + 400 CMOVE LOOP ; --> ( PRINT GRAPHICS SCREEN ) HEX : PICTURE PRINT 4400 4000 DO I 8LINES 80 +LOO: NN ( LIST NEXT SCREEN ) 1 SCR +! L ; : BB ( LIST PREVIOUS SCREEN ) -1 SCR +! L ; --> ( STRING EDITING COMMANDS ) : 1LINE P 4428 4028 DO I 8LINES 80 +LOOP 4450 4050 DO I 8LINES 80 +LOOP TUBE ; : BIG.PICTURE 1 DOUBLE ! PICTURE ; DECIMAL ;S ( **************** TEXT LINE EDITOR ************************ ) CR ." LOADING TEXT LINE EDITOR" C ( SCAN LINE WITH CURSOR FOR MATCH TO PAD TEXT ) ( UPDATE CURSOR, RETURN BOOLEAN ) #LAG PAD COUNT MATCH R# +! ; : FIND ( STRING AT PAD OVER FULL SCREEN RANGE, ELSE ERROR ) BEGIN 3FF R# @ < IF TR ( ' TASK FENCE ! FORGET TASK ) FORTH DEFINITIONS HEX : TEXT ( ACCEPT FOLLOWING TEXT TO PAD ) HERE C/L 1+ BLANKS WORD HERE PAD C/L 1+ CMOVE ; : LINE ( RELATIVE TO SCR, LEAVE ADDRESS OF LOP PAD HERE C/L 1+ CMOVE 0 ERROR ENDIF 1LINE UNTIL ; : DELETE ( BACKWARDS AT CURSOR BY COUNT-1 ) >R #LAG + FORTH R - ( SAVE BLANK FILL LOCATION ) #LAG R MINUS R# +! ( BACKUP CURSOR ) #LEAD + SWAP INE ) DUP FFF0 AND 17 ?ERROR ( KEEP ON THIS SCREEN ) SCR @ (LINE) DROP ; --> ( LINE EDITOR ) VOCABULARY EDITOR IMMEDIATE HEX EDITOR DEFINITIONS : #LOCATE CMOVE R> BLANKS UPDATE ; ( FILL FROM END OF TEXT ) --> ( STRING EDITOR COMMANDS ) : N ( FIND NEXT OCCURANCE OF PREVIOUS TEXT ) FIND 0 M ; : F ( FIND OCCUR ( LEAVE CURSOR OFFSET-2, LINE-1 ) R# @ C/L /MOD ; : #LEAD ( LINE ADDRESS-2, OFFSET-1 TO CURSOR ) #LOCATE LINE SWAP ; : #LAG ( CURSOR ADDRESS-2, COUNT-1 AFTER CURSOR ) #LEAD DUP ANCE OF FOLLOWING TEXT ) 1 TEXT N ; : B ( BACKUP CURSOR BY TEXT IN PAD ) PAD C@ MINUS M ; : X ( DELETE FOLLOWING TEXT ) 1 TEXT FIND PAD C@ DELETE 0 M ; >R + C/L R> - ; : -MOVE ( MOVE IN BLOCK BUFFER ADDR FROM-2, LINE TO-1 ) LINE C/L CMOVE UPDATE ; --> ( LINE EDITING COMMANDS ) : H ( HOLD NUMBER : TILL ( DELETE ON CURSOR LINE, FORM CURSOR TO TEXT END ) #LEAD + 1 TEXT 1LINE 0= 0 ?ERROR #LEAD + SWAP - DELETE 0 M ; --> ( STRING EDITOR COMMANDS ) : C ( SPREAD AT CURSOR ED LINE AT PAD ) LINE PAD 1+ C/L DUP PAD C! CMOVE ; : E ( ERASE LINE-1 WITH BLANKS ) LINE C/L BLANKS UPDATE ; : S ( SPREAD MAKING LINE # BLANK ) DUP 1 - ( AND COPY IN THE FOLLOWING TEXT ) 1 TEXT PAD COUNT #LAG ROT OVER MIN >R FORTH R R# +! ( BUMP CURSOR ) R - >R ( CHARS TO SAVE ) DUP HERE R CMOVE ( FROM OLD CURSOR TO HERE ) HERE #LEAD + R> CMOVE ( HERE TO CURSORLIMIT ) 0E ( FIRST TO MOVE ) DO I LINE I 1+ -MOVE -1 +LOOP E ; : D ( DELETE LINE-1, BUT HOLD IN PAD ) DUP H 0F DUP ROT DO I 1+ LINE I -MOVE LOOP E ; --> ( LINE EDITING COMMANDS  LOCATION ) R> CMOVE UPDATE ( PAD TO OLD CURSOR ) 0 M ( LOOK AT LINE ) ; FORTH DEFINITIONS DECIMAL ;S ( STOP COMPILING FOR NOW ) LATEST 12 +ORIGIN ! ( TOP MOST WORD IN FORTH VOCABULARY ) HERE 28 +ORIGIN ! ( FENCE ) HERE  ) : M ( MOVE CURSOR BY SIGNED AMOUNT-1, PRINT ITS LINE ) R# +! CR SPACE #LEAD TYPE 5F EMIT #LAG TYPE #LOCATE . DROP ; : T ( TYPE LINE BY #-1,  30 +ORIGIN ! ( DP ) ' EDITOR 6 + 32 +ORIGIN ! ( VOC-LINK ) HERE FENCE ! ;S ( ?BREAK -- BREAK CONDITION, ?T/P ) 00 VARIABLE END.PAGE : ?Y/N ." Y/N? " KEY DUP EMIT 89 = ; : ?BREAK ( DO WE HAVE A KEYBOARD INTERRUPT? ) ?TERSAVE ALSO IN PAD ) DUP C/L * R# ! DUP H 0 M ; : L ( RE-LIST SCREEN ) SCR @ LIST 0 M ; --> ( LINE EDITING COMMAND ) : R MINAL IF TUBE CR KEY DROP ( EAT UP KEY ) ." FINISH PAGE AND PAUSE? " ?Y/N IF 1 END.PAGE ! PRINT ELSE TUBE QUIT THEN THEN ; --> ( DOCUMENT -- DOCUMENT A FORTH DISK ) HEX : NP C EMIT END.PAGE @ IF TUBE 0      END.PAGE ! TUBE CR ." HIT RETURN TO RESTART " KEY DROP PRINT THEN ; DECIMAL : LINDEX ( INDEX TO LINE PRINTER ) PRINT 0 59 INDEX NP 60 119 INDEX NP 120 179 INDEX NP 180 239 INDEX NP 240 249 INDEX NP TUBE ;ERE C@ 8 MIN CMOVE ( WRITE NEW NAME ) ; : >EXT ( HERE TO EXTENSION ) FCBFN 8 + 3 32 FILL ( BLANK OLD EXTENSION ) HERE 1+ FCBFN 8 + HERE C@ 3 MIN CMOVE ( WRITE EXT ) ; : KEY>FNAME ( INPUT FNAME FROM KEYBOARD ) CR ." ENTER 'FI : TT ( DO TRIAD ) PRINT TRIAD ?BREAK NP TUBE ; : SHOW 1+ SWAP DO I TT 3 +LOOP ; ;S ( INPUT NUMBER UTILITIES ) : #IN ( INPUT A NUMBER, CR EXITS TO INTERPRETER ) QUERY BL WORD HERE NUMBER DROP ; : #IN.FORCE ( INPULENAME.EXT' --> " QUERY TIB @ 1+ C@ 58 = IF ( : ) 2 IN +! TIB @ C@ 66 - IF DRA ELSE DRB THEN THEN 46 ( . ) WORD HERE 1+ C@ 0= IF QUIT ( NULL ENTRY ) THEN >FNAME BL WORD HERE 1+ C@ IF >EXT THEN ; --> ( MAKE, CREATE AT A NUMBER, FORCED ) BEGIN QUERY BL WORD 0 0 HERE (NUMBER) C@ 32 - WHILE DROP DROP CR ." # " REPEAT DROP ; : #IN.RET ( INPUT A NUMBER, RETURNS 1 FOR A NUMBER ) ( 0 FOR A CR, NULL LINE ) BEGIN [ DROP ] QUERY BL FILE ) : MAKE ( MAKE A FILE FROM THE CURRENT FCB ) *MAKE ( MACHINE CODE ) 255 = IF ( PRINT ) CR ." NOT ENOUGH ROOM IN DIRECTORY" QUIT THEN ; : CREATE ( ASK FOR THE FILE AND CREATE IT ) KEY>FNAME M WORD 0 0 HERE (NUMBER) C@ DUP 0= IF ( NULL ) SWAP DROP SWAP ELSE [ ROT 1 ] ( NOT NULL ) 32 - 0= WHILE [ 2 - ] ( # ) 1 SWAP ELSE [ 2 + ] ( JUNK ) DROP DROP CR ." # " REPEAT THEN DROP ; ;S ( PRINTER ENABLE, DISABLE AKE ; --> ( .NOFILE ) : .NOFILE ( PRINT NO FILE ERROR MESSAGE ) CR ." CANNOT FIND FILE " FCBFN 8 TYPE ." ." FCBFN 8 + 3 TYPE QUIT ; --> ( CP/M BDOS COMMANDS IN 8080 CODE -- *ERA ) HEX ' --> 1A + CONSTANT EPRINT : PRINT ( ENABLE PRINTER ) 1 EPRINT C! ; ( WRITE 1 INTO ENABLE BYTE ) : TUBE ( DISABLE PRINTER ) 0 EPRINT C! ; ( WRITE 0 INTO ENABLE  ) CODE *ERA ( ERASE A CP/M FILE IN DIRECTORY ) B PUSH ( SAVE INTERPRETIVE POINTER ) 19 C MVI BDOSCMD JMP C; : (ERA) ( ERASE THE FILE IN FCB ) *ERA ( MACHINE LANGUAGE ) 255 = IF .NOFILE THEN ; : ERA ( ASK FBYTE ) : ESC 1B EMIT ; ( ESCAPE CHARACTER ) : REST PRINT ESC 0D EMIT ." P" TUBE ; ( RESTORE PRINTER ) DECIMAL --> ( PRINTER DEFINITIONS ) ( FOR DIABLO PRINTERS ) : HT ( HORIOR FILE AND DELETE ) KEY>FNAME (ERA) ; --> ( OPEN A FILE -- *OPEN ) CODE *OPEN B PUSH ( SAVE POINTER ) 15 C MVI BDOSCMD JMP C; CODE *CLOSE B PUSH ( SAVE POINTER ) 16 C MVI BDOSCMD JMP ZONTAL ABSOLUTE TAB ) ESC 09 EMIT ( STACK ) EMIT ; : VT ( VERTICAL ABSOLUTE TAB ) ESC 11 EMIT ( STACK ) EMIT ; HEX : LF A EMIT ; : BS 8 EMIT ; : NP 0C EMIT ; FF 0C EMIT ( MULTIPLE DEF ) : HMI ( C; : (OPEN) ( OPEN THE FILE IN FNAME ) FCB 12 + 24 0 FILL *OPEN 255 = IF .NOFILE THEN ; : CLOSE ( CLOSE THE FILE IN FNAME ) *CLOSE 255 = IF .NOFILE THEN ; --> ( OPEN, SET DMA -- BUFFER ADDRESS ) : OPEN (  OUTPUT HMI ON STACK ) ESC 1F EMIT EMIT ; : VMI ( OUTPUT VMI ON STACK ) ESC 1E EMIT EMIT ; : RESET ESC 1A EMIT ." I" ; DECIMAL : NOR.HMIVMI 13 HMI 9 VMI ; ;S ( ********* CP/M INTERFACE AND DIRECTORY STRUCTURE ***OPEN THE FILENAME ) KEY>FNAME (OPEN) 0 C.REC C! ; CODE *SETDMA ( SET THE DMA ADDRESS ) D POP ( TAKE STACK ENTRY ) B PUSH ( SAVE INTERPRETIVE POINTER ) HEX 1A C MVI DECIMAL BDOS CALL B POP NEXT JMP C; -->***** ) HEX 0005 CONSTANT BDOS ( DOS ENTRY POINT ) 000F CONSTANT OPENFC ( OPEN FILE CONSTANT ) 0016 CONSTANT MAKEFC ( MAKE FILE CONSTANT ) 0014 CONSTANT READFC ( READ FILE CONSTANT ) 005C CONSTANT FCB ( FILE CONTROL BLOCK ) 0080 C ( RANDOM FILE READ -- *RREAD ) CODE *RREAD ( RANDOM READ ) B PUSH ( INTERPRETIVE POINTER ) HEX 21 C MVI DECIMAL ( READ CODE ) BDOSCMD JMP C; : RREAD ( READ RANDOM RECORD ON STACK TO DMA ) 0 R.REC 2 + C!ONSTANT BUFF ( INPUT BUFFER ADDRESS ) DECIMAL FCB 0 + CONSTANT FCBDN ( DISK NAME ) FCB 1 + CONSTANT FCBFN ( FILE NAME ) FCB 9 + CONSTANT FCBFT ( FILE TYPE, 3 LETTERS ) FCB 12 + CONSTANT FCBRL ( FILES CURRENT REEL NUMBER ) FCB 15 +  R.REC ! *RREAD 25 ?ERROR ; --> ( SEQUENTIAL FILE READ -- *SREAD ) 00 VARIABLE PTR 29178 CONSTANT DBUFF1 30206 CONSTANT DBUFF2 CODE *SREAD ( SEQUENTIAL READ ) B PUSH ( INTERPRETIVE POINTE CONSTANT FCBRC ( FILE' RECORD COUNT 0-128 ) FCB 32 + CONSTANT C.REC ( CURRENT RECORD ) FCB 33 + CONSTANT R.REC ( RANDOM REC # ) --> ( CP/M BDOS COMMANDS IN 8080 CODE ) LABEL BDOSCMD ( MAKE A CP/M FILE IN DIRECTORY ) FCB D LXI R ) HEX 14 C MVI DECIMAL ( READ CODE ) BDOSCMD JMP C; : 8IN ( READ IN 8 BLOCKS RANDOMLY, TO USE ) 0 PTR ! 8 0 DO DBUFF1 PTR @ + *SETDMA ( SET ADDRESS ) *RREAD 1 R.REC +! IF LEAVE THEN 128 PTR +! LOOP BUF ( FILE CONTROL BLOCK IN DE ) BDOS CALL ( CALL CP/M ) 0 D MVI A E MOV B POP D PUSH ( ERROR CODE TO STACK ) NEXT JMP ( BACK TO FORTH ) C; CODE *MAKE ( MAKE THE FILE ) B PUSH ( SAVE INTERPRETIVE POINTER ) F *SETDMA ; --> ( VM>RAM -- ) 00 VARIABLE FROM.D 00 VARIABLE CT : COMPILE.RAM DBUFF2 ; : VM>RAM ( FROM DISK-2,TO USE BUFFER, <=900 BYTES-1 ) EMPTY-BUFFERS CT ! ( COUNT IN CT ) FROM.D ! ( FROM PTR IN FROM.D VARIAB MAKEFC C MVI BDOSCMD JMP C; : DRA ( SET DRIVE A ) 1 FCB C! ; : DRB ( SET DRIVE B ) 2 FCB C! ; --> ( >FNAME, >EXT, KEY>FNAME ) : >FNAME ( HERE TO FILE NAME ) FCBFN 11 32 FILL ( BLANK OLD NAME ) HERE 1+ FCBFN HLE ) FROM.D @ 0 128 U/ SWAP DROP R.REC ! 8IN ( READ INTO USE ) DBUFF1 FROM.D @ 0 128 U/ DROP + COMPILE.RAM CT @ CMOVE ; --> ( SFIRST, SNEXT -- SEARCH DIRECTORY FUNCTIONS ) CODE *SFIRST B PUSH ( SAVE INT PTR )       HEX 11 C MVI ( FUNCTION CODE ) BDOSCMD JMP ( DO BDOS COMMAND ) C; CODE *SNEXT B PUSH ( SAVE INT PTR ) HEX 12 C MVI ( FUNCTION CODE ) BDOSCMD JMP ( DO BDOS COMMAND ) C; DECIMAL --> ( DIR -- P CP/M FILE TRANSFER ) : OPEN/MAKE ( OPEN OR MAKE A FILE IN FNAME ) *OPEN 255 = IF MAKE THEN ; : 4TH>CPM CR ." INPUT FORTH SCREEN 'FROM' " #IN CR ." INPUT FORTH SCREEN 'TO' " #IN KEY>FNAME ( ASK FOR NAME ) ORINT DIRECTORY ) 00 VARIABLE SCRATCH 00 VARIABLE COL.CTR ( COLUMN COUNTER ) : FNAME>? ( SET FILE NAME AMBIGUOUS ) FCBFN 11 63 FILL ( FILE NAME TO ? ) ; : .DR: ( PRINT DRIVE AND COLEN ) FCB C@ 64 + EMIT ." : " ; : .NAME ( PPEN/MAKE ( OPEN OR MAKE THE FILE ) 1+ SWAP DO I NLIST LOOP CLOSE CR ." END TRANSFER" CR ; ;S ( NEW CP/M ERROR MESSAGE PRINTER ) 00 VARIABLE ERROR.STRING -2 ALLOT HEX 45 C, 52 C, 52 C, 4F C, 52 C, 20 C, 20 C, 20 C, RINT THE NAME OF THE FILE ) BUFF 1+ SCRATCH @ 32 * + DUP 8 TYPE SPACE 8 + 3 TYPE 1 COL.CTR +! COL.CTR @ 4 = IF CR .DR: 0 COL.CTR ! ELSE ." : " THEN ; --> ;S ( DIR -- PRINT DIRECTORY ) : DIR ( SCAN DIRECTORY ) C54 C, 58 C, 54 C, ( ERROR TXT IN ASCII ) DECIMAL : NMESSAGE ( NEW MESSAGE PRINT ) WARNING @ IF ( DISC AVAILABLE ) FCB PAD 36 CMOVE FCB 1+ 35 0 FILL ERROR.STRING FCBFN 11 CMOVE *OPEN 255 = IF ." MSG # " . ELSE DUP 2 / RRER FNAME>? ( SET FNAME TO ? ) 0 COL.CTR ! .DR: *SFIRST ( START SCAN ) 255 - IF 0 SCRATCH ! .NAME ( FIRST ENTRY ) BEGIN *SNEXT DUP SCRATCH ! 255 - WHILE .NAME ( PRINT NAME ) REPEAT CR THEN AD 1 AND IF BUFF 64 + ELSE BUFF THEN 64 -TRAILING TYPE SPACE THEN PAD FCB 36 CMOVE ELSE ." MSG # " . THEN ; --> ( RE-WRITE OLD WORD ) HEX ' MESSAGE CONSTANT OLDMESSAGE ' NMESSAGE 2 - CONSTANT NEWMESSA FCBFN 11 32 FILL ; --> ( *SWRITE -- SEQUENTIAL WRITE ) CODE *SWRITE B PUSH ( SAVE INTERPRETIVE POINTER ) HEX 15 C MVI BDOSCMD JMP C; DECIMAL --> ( SAVE APPLICATION RGE : XX NEWMESSAGE OLDMESSAGE ! 04F1 OLDMESSAGE 2+ ! ; XX FORGET OLDMESSAGE DECIMAL ;S ( SAVE APPLICATION ROUTINE ) : OPEN/MAKE ( OPEN OR MAKE A FILE IN FNAME ) *OPEN 255 = IF MAKE THEN ; : WRITED *SWROUTINE ) : OPEN/MAKE ( OPEN OR MAKE A FILE IN FNAME ) *OPEN 255 = IF MAKE THEN 0 C.REC C! ; : WRITED *SWRITE IF ." DISC WRITE ERROR" QUIT THEN ; ;S : SAVE.APP ( SAVE APPLICATION ) KEY>FNAME OPEN/MAKE ( OPEN A FILE ) HERITE IF ." DISC WRITE ERROR" QUIT THEN ; : SAVE.APP ( SAVE APPLICATION ) KEY>FNAME OPEN/MAKE ( OPEN A FILE ) FENCE @ REMEMBER 256 BUFF 128 CMOVE WRITED HERE SWAP DO I BUFF 128 CMOVE WRITED 128 +LOOP CLOSE ; : LOADE BUFF 2 + ! FENCE @ DUP BUFF ! REMEMBER 256 BUFF 4 + 124 CMOVE WRITED HERE SWAP DO I BUFF 128 CMOVE WRITED 128 +LOOP CLOSE ; --> ( SAVE APPLICATION ROUTINE ) HEX : WR.USER ( WRITE USER AREA FROM COLD START ) 112 126 .APP ( LOAD APPLICATION ) OPEN ( ASK FOR FILE ) *SREAD BUFF 256 128 CMOVE ( 1ST BLOCK ) 30000 0 DO *SREAD 0= IF BUFF HERE I + 128 CMOVE ELSE COLD THEN 128 +LOOP ; ;S ( ACCEPT SCREEN FROM PRINTER PORT ) 00@ 6 + 10 CMOVE 10C @ 10BE ! ; DECIMAL : *LOAD.APP ( LOAD APPLICATION ) *SREAD BUFF 4 + 256 32 CMOVE ( 1ST BLOCK ) BUFF @ DP ! 30000 0 DO *SREAD 0= IF BUFF HERE I + 128 CMOVE ELSE WR.USER LEAVE THEN 128 +LOOP ; : LOAD.APP  VARIABLE RAM ( RAM BUFFER ) 10240 ALLOT 00 VARIABLE RAM.PTR HEX CODE INPUT ( GET FROM PRINTER PORT ONE BYTE ) A ORA B PUSH BEGIN EA39 CALL CS NOT UNTIL B POP A E MOV 0 D MVI D PUSH NEXT JMP C; DECIMAL : ACCEPT CR ." AC OPEN *LOAD.APP ; ;S ( SAVE APPLICATION ROUTINE ) HEX : WR.USER ( WRITE USER AREA FROM COLD START ) 112 126 @ 6 + 10 CMOVE ; DECIMAL : *LOAD.APP ( LOAD APPLICATION ) *SREAD BUFF 4 + 256 32 CMOVE ( 1ST BLOCK ) BUFF @CEPTING INPUT FROM PORT -- 10 SCREENS" BEGIN INPUT 3 = UNTIL ( WAIT FOR STX ) 10240 0 DO INPUT ( GET BYTE ) RAM I + C! LOOP CR ." GIVE DESTINATION SCREEN NUMBER " #IN CR ." WRITING TO DISK " 0 RAM.PTR ! 10 0 DO DUP RAM R DP ! 30000 0 DO *SREAD 0= IF BUFF HERE I + 128 CMOVE ELSE WR.USER THEN 128 +LOOP ; : LOAD.APP OPEN *LOAD.APP ; ;S ( SECTOR DUMP UTILITY ) 00 VARIABLE #SEC : SECTOR DUP #SEC ! ." SECTOR # " DUP . CR 8 /MOD AM.PTR @ + SWAP 0 R/W 1024 RAM.PTR +! 1+ LOOP DROP EMPTY-BUFFERS ; ;S ( **** TLOAD -- CP/M WORDSTAR TEXT COMPILATION ********* ) 00 VARIABLE F.PTR ( FILE PTR ) 00 VARIABLE ?TLOAD : SP.WORD ?TLOAD @ 0= IF BLK @ IF BLK BLOCK SWAP 128 * + 128 DUMP ; : WR ( WRITE SECTOR SEQUENTIAL ) DUP #SEC ! 8 /MOD BLOCK SWAP 128 * + BUFF 128 CMOVE CR ." C.REC IS " C.REC C@ . BUFF 128 DUMP BUFF *SETDMA *SWRITE ; : NN #SEC @  @ BLOCK ELSE TIB @ THEN ELSE COMPILE.RAM THEN IN @ + SWAP ENCLOSE HERE 34 32 FILL IN +! OVER - >R R HERE C! + HERE 1+ R> CMOVE ; : WARN ( ISSUE WARNING ) HERE COUNT TYPE CR HERE COUNT TYPE ." ? NOT DEFIN1+ SECTOR ; : BB #SEC @ 1 - SECTOR ; ;S ( SEQUENTIAL FILE WRITE -- 8OUT ) : 8OUT ( WRITE OUT 8 BLOCKS SEQUENTIALLY, FROM PREV ) 0 PTR ! 8 0 DO PREV @ 2 + PTR @ + *SETDMA ( SET ADDRESS ) *SWRITE IF LEAVE THED -- CONTINUING... " DROP 0 ; --> ( TESTING OF SOURCE COMPILING ) 00 VARIABLE DBUG : .DEBUG HERE 1+ C@ 58 = IF CR ." COMPILING --> " COMPILE.RAM IN @ + 32 ENCLOSE DROP SWAP DROP TYPE SPACE THEN ; : SP.FIND ( SPECIAL FIND ) EN 128 PTR +! LOOP BUFF *SETDMA ; : NLIST SCR ! 16 0 DO I SCR @ (LINE) OVER DUP 62 + 2573 SWAP ! 126 + 2573 SWAP ! DROP ( 64 ) *SETDMA *SWRITE 2 +LOOP BUFF *SETDMA ; --> ( FORTH SCREENS TO BL SP.WORD DBUG @ IF .DEBUG THEN HERE CONTEXT @ @ (FIND) DUP 0= IF DROP HERE LATEST (FIND) THEN ; : SP.NUMBER ( SPECIAL NUMBER PROCESS ) 0 0 ROT DUP 1+ C@ 45 = DUP >R + (NUMBER) SWAP DROP C@ 32 - IF WARN ( ISSUE WARNING ) TH     EN R> IF MINUS THEN ; --> ( INTERPRET ) : INTERPRET ( NOTE: SINGLE NUMBERS ONLY ) BEGIN SP.FIND IF STATE @ < IF CFA , ELSE CFA EXECUTE THEN ?STACK ELSE HERE SP.NUMBER [COMPILE] LITERAL ?STACK THEN AGAIN ; -->  --> ( TESTING OF SOURCE COMPILING ) : SCAN/AHEAD ( PREPARE COMPILE.RAM ) COMPILE.RAM 600 OVER + SWAP DO I C@ 127 AND DUP 32 < IF ( CONTROL ) DROP 32 ( BLANK ) THEN I C! LOOP COMPILE.RAM 600 + 80 OVER + SWAP DO I C@ 127 AND DUP 20 < IF DROP 0 0 I 1+ C! I COMPILE.RAM - F.PTR +! LEAVE THEN I C! LOOP ; --> ( TESTING OF SOURCE COMPILING ) : NEXT.BLK ?TLOAD @ IF F.PTR @ 768 VM>RAM SCAN/AHEAD ( PREPARE RAM ) 0 IN ! ELSE ( NORMAL ) 1 BLK +! THEN ; --> ( TESTING OF FILE MAPPING ) : TLOAD EMPTY-BUFFERS -1 WARNING ! KEY>FNAME (OPEN) 0 F.PTR ! IN @ >R 0 IN ! 1 ?TLOAD ! NEXT.BLK ( FETCH BLOCK ) INTERPRET R> IN ! CR ." END TEXT COMPILATION" CR FCB 1+ 35 0 FILL 0 ?TLOAD ! 1 WARNING ! ; --> ( TESTING OF FILE MAPPING ) HEX 8081 HERE : X ?TLOAD @ IF NEXT.BLK 0 IN ! ELSE BLK @ IF 1 BLK +! 0 IN ! BLK @ 3 AND 0= IF ?EXEC R> DROP THEN ELSE R> DROP THEN THEN ; ! IMMEDIATE : -ABORT- ( NEW ABORT ) 0 ?TLOAD ! CR ." ABORTING COMPILE " 1 WARNING ! ERROR ; ' -ABORT- 2 - ' (ABORT) ! ( RE-WRI  $H9ALLOTT`4$ĸ U%1BRANPS$$ RCSLLT D5U%( =55CFAPԠT4dX JCOUNTӕ TDtH DOESQ`TDԔXA1UNDPLQՐTTD4 @DDUP TEE$AUM"DOCOL 4EU9 2EQUALVPTe$(%12FENCEQԑPU DU$X !1HOLITE VECTOR ) --> ( RE-WRITE OLD WORD ) HEX ' WORD CONSTANT OLDWORD ' SP.WORD 2 - CONSTANT NEWWORD : XX NEWWORD OLDWORD ! 04F1 OLDWORD 2+ ! ; XX FORGET OLDWORD DECIMAL ;S ( TESTING OF FILE MAPPING ) : -ABDRT 4 %>LITSP4d1YLESSSUTTԔU89aRNFA D$x =IJOUTTՑT4X=9BPLUSQ 5dAMQ=JPDOTQTS EU%(EUIfQCOMPTTRTUDU$ IJROTԔ U%5DM]BSZEROTE5HMQQSEMISTԑ`E5T$(MA TIBEEtQ!ITDORT- ( NEW ABORT ) CR HERE COUNT TYPE ." ? " MESSAGE ; ' -ABORT- 2 - ' (ABORT) ! ( RE-WRITE VECTOR ) ;S UPԠUDttQeAUSTART UTU58UM1NVOCLTUtED a>XPLOOԔUiEVZLESSVSEU$@|.ZaO\C0q I(@\W7frtɄO@3x(gaҰ9E!JZnU,:d!$"V0#+ $#!"CdU >Ua0O'5Ȁ@ U(? wwծ=B4ـb3iXb*P`P+&M` B MP+b*P9MFra &_@U(/V,B $rKRP D>8 -`;+ו'/@ *60XPF$MZ.(i\&W!U|PD Pe -U@@ *mVin@!7YxFV=,T!tE'ɄP{M|ʱ-V)aZ0j`F_2 N´`,UK-PUKRi%^@o aj5\ h2Yon DʄR4N .x  0Ci] _j5)M'L E0LxXKEUUM }f ')Df &(XSUB L80 /D:0,/P:0100,B:FORTH5,B:FORTH5/X/N:P/Y /E ZSID IB:FORTH5.HEX B:FORTH5.SYM R OAK820 SUBAFORTHDOSTXTxyz{|}~FORTHVM TXT 4THCOMP4TXT<Mv UJ 8) xe8%UW*!%㈌p`Oa]/Ea!@RuZV&uޭ+ }Hω;́R&`ҳ`@M=aW& å2 9UxE{RJC; +Np@.zZtX'hOjyXgaҰLWBXtS((nR`/η EbPå`2ACA@AxFVu@ m:&LT##TK)ťu( UJ 2#90`|Ҩux *Xg&,A\@xFV@UK-*}CnB0JC`nHiZ1 Uvpځ\!+Av@x#+.˭}Dψ;å`Ri$Ui۰;>yFå`b!4N*pR2+ x3XtO+ZW4\.V*B D,B ȅV,@+!DBBUG EaҠCQ*#~AgQ݇KByLbpJpgv,@+P%pef l d&0JC&/P/V,@l%pNb3 jh rA- J u     -#hg&,`x%H"XJ n 8[ETVpDT&K!0`wx/%b'  I@,DPNjQ[ }A)M !7YxFVj` A)H$"c߰Jl [BmV,BJdVI`eUI,:VXUZ V5@ gbj( !3,-@d1{2R F$mKB P_)0M$-X-@!yƶB2JP+'$rK:߰Jz@-1Al"P@T$-l!J!Q@A`(1W ĒsVPrE'شTDF"$AXC $]-@ LePj AYdRVP CiUPj CbW`(yC'RRVQU)s$)LA*1l5l!DƃVQ2 PfYj (AKD [EH2Mj`(RQ@j .A Kz [FWqA%`t 2Uk cm1B&-`S4)L'/H5@pU_kp ch=1AՔ _k ah=1>ѝVрzlpiH; WS@{L@+|T.ұVٴH%}VPqå`JEUJ`8Z: R`KBc@M1@X=`8D J2ų΂0b L~*%y*%1D DSb`{ L(%8<S410T"ڗ$Xk `A) F`{ O@ hL@d23_K M F`0 O@ hO@L@e3_K ulXSUB L80 /D:0,/P:0100,B:FORTHBAS,B:4THCOMP5,B:FORTH5/X/N:P/Y /E ZSID IB:FORTH5.HEX B:FORTH5.SYM R LINK41 $$$FORTHDOSTXTxyz{|}~FORTHVM TXT 4THCOMP4TXT<BC))EVS40R)U,"S0J ?!ɭ ~,5t" ?":~,5 e ha@I)4xE& ?!"^P+t `A)== +(E1DɄ Nc۠ R%`e hr` ``R ص.WZL@"aKi0 gAk]1B % ``pXK L@e ߰K O@ fL@11=R;ZS# R;> Tc 2;XPS@ 1.:S5 U%1; U#! 2#U 5=Y:PSPc =5B: ӕ#5 =U9R;ԣ' IR;N # MQ=J; TUB:P5%%R;QRSc`= =2: Qӣ!5==;ZT@=YJ:d # @;P #uA1UN:TQT#I=B:*QRcUB;S#@EU22QTԣ@a:T QScaq%122@Qԕ#@uI=5J; QԑPU#!I; #aq!=1:VRT#@ %>2<SU#@%9:;SUT51 I:SPUc1MN:c 1%R;SRST㥀9aR:Nӑc9==B2d㰀=9; ӑT#=I%;~Ԕ`=UQR:. ՑTamA3ԣUA=QF3TSRU# A:hTS#;1A-f;fT=5AEQJ: TԣE =5B:QTEA%J;TUTc%AyEQ1=: TUQTcI=R:PԔ# uIAMQ>;  uM5%N;\TPcQMAR;T㲠MQQ;p TԑcMU :f T#MiI>2TQUB;( UQcQ% : U#mQ=J;  Q]=B;TcU1MN:LT# UUM1N:HUTTY= 2:> T@]%Q"3ԑ# ]I6;a1==B;Ԕ aA1=>:VSqiEV: T ui1MNp ( ***************** FORTH DOS DEVELOPMENT ***************** ) ( AS DEPICTED IN BYTE MAGAZINE--APRIL 1982 ) --> ( FORTHDOS UTILITIES ) : *LOCK ( LOCKOUT ANY BLOCKS THE USER WISHES TO MAR;T㲠MQQ;p TԑcMU :f T#MiI>2TQUB;( UQcQ% : U#mQ=J;  Q]=B;TcU1MN:LT# UUM1N:HUTTY= 2:> T@]%Q"3ԑ# ]I6;a1==B;Ԕ aA1=>:VSqiEV: T ui1MNpBE PROTECTED ) BEGIN ." BLOCK # TO BE LOCKED OUT " ( -1 IF NONE ) #IN DUP -1 = IF DROP 1 ELSE DON 0 THEN CR UNTIL ; *LOCK FORGET *LOCK ;S ( SETDIR, SETUP NEW DIRECTORY VIA PROMPTS TO THE US     ER ) : *SETDIR 26 EMIT ( CLEAR SCREEN ) ." NEW DIRECTORY" CR CR ." BUILD A NEW DIRECTORY ( & DESTROY ALL FILES ) " ?Y/N IF DINIT CR ." WRITE PROTECT BELOW BLOCK # " #IN 0 DO I DON LOOP CR LOCK FNAME  I + C@ SWAP I + C@ ( FETCH BYTES ) OVER OVER > IF LEAVE DROP DROP DROP DROP 1 ELSE - IF ( NOT = ) LEAVE DROP DROP 0 THEN THEN SCRATCH @ I = IF ( LAST COMP ) DROP DROP -1 THEN LOOP ; --> ( 8 /, 8 * WRITTEN IN CO64 0 FILL DIRBLK @ DON DWR DADRS @ 64 + N ! ." DISKETTE DESCRIPTION: " FNAME 64 EXPECT FNAME N @ 64 CMOVE FNAME 64 0 FILL DSAVE THEN CR ; *SETDIR FORGET *SETDIR ;S ( RENAME -- GIVE AN OLD FILE A NEW NDE ) CODE 8/ ( DIVIDE TOP OF STACK BY EIGHT ) HEX D POP E A MOV F8 ANI ( CLEAR CARRY ) RRC RRC RRC A E MOV D PUSH NEXT JMP C; CODE 8* ( MULTIPLY TOP OF STACK BY EIGHT ) D POP E A MOV 1F ANI AME ) : *RENAME SPACE BM1 C@ -2 - IF ." OLD" NAME LOOKUP -1 = IF SPACE ." * NOT FOUND " QUIT ELSE RENM SPACE ." NEW" NAME FNAME N @ 15 CMOVE CR THEN ELSE LOOKUP 255 - IF @ FNAME SWAP 15 CMOVE RLC RLC RLC A E MOV D PUSH NEXT JMP C; DECIMAL --> ( FORTHDOS -- DISK OPERATING SYSTEM ) : CARRAY ( CREATE AN ARRAY OF RAM ) ( FORMAT --> LENG CARRAY NAME ) 00 VARIABLE -2 ALLOT ( STACK ) ALLOT ; 2 THEN THEN ; *RENAME FORGET RENAME ;S ( COPYALL -- COPY TOS BLOCKS OF THE FILE IN 'ONAME' > 'FNAME' ) : *COPYALL 0 DO FNAME TMP 10 CMOVE ONAME FNAME 10 CMOVE BUFF READ TMP FNAME 10 CMOVE 50 CONSTANT DSKSZ ( SIZE OF DISK -- BLOCKS ) 86 VARIABLE DIRBLK ( ADDRS OF DIRECTORY BLOCK ) 10 VARIABLE AUXBLK ( ADDRS OF UTILITY PROGRAMS ) DSKSZ 8 / 1+ CONSTANT MAPSZ ( SIZE OF BITMAP ) : BUFF PREV @ 2 + ; ( BUFFER RAM ) MAPSZ CARRAY  BUFF WRITE LOOP CR ONAME 10 TYPE ." COPIED TO " FNAME 10 TYPE CR ; *COPYALL FORGET COPYALL ;S ( FCOPY -- COPY ONE FILE TO ANOTHER ) : *FCOPY ." COPY FROM" NAME LOOKUP -1 = IF ." * NO SUBITMAP ( BITMAP TABLE ) MAPSZ CARRAY QMAP ( FILE BITMAP TABLE ) 1024 CARRAY DBUFF ( DIR HOLDING BUFFER ) 64 CARRAY FNAME 10 CARRAY ONAME ( FILE NAME BUFFERS ) DBUFF VARIABLE DADRS ( START OF DIRECTORY BUFFER ) --> ( FORTHCH FILE" QUIT ELSE FSIZE BM1 C@ N1 ! FNAME ONAME 10 CMOVE SPACE ." TO" NAME SPACE LOOKUP 255 = IF CR ." (NEW FILE)" DPUTNM N1 @ COPYALL ELSE CR ." (COPY OVER OLD FILE) " ?Y/NDOS VARIABLES ) 0 VARIABLE NBLK ( CURRENTLY ACCESSED BLOCK ) 0 VARIABLE BM1 ( TEMPORARY STORAGE ) 0 VARIABLE BM2 0 VARIABLE BM3 0 VARIABLE N 0 VARIABLE N1 101 CARRAY TMP 8 CARRAY MASK ' MASK DP ! HEX 1 C, 2 C, 4 C, 8 IF PROT? 0= IF KILL (MAKE) N1 @ COPYALL ELSE CR ." FILE IS WRITE PROTECTED" CR THEN THEN THEN THEN ; *FCOPY FORGET FCOPY ;S ( TRANSFER DRIVE B SCREENS TO FILE ) : *TRANSFER CR ." GIVE DESTIN C, 10 C, 20 C, 40 C, 80 C, DECIMAL : 2[ ( FIND MASK ) MASK + C@ ; --> ( FORDTHDOS PRIMITIVES ) : T# 0 <# # #S #> TYPE ; ( TYPE A NUMBER ) : C+! DUP C@ ROT + SWAP C! ; ( ADD TOS TO CVAR ) : C-ATION " MAKE CR 1+ SWAP DO DR1 I LIST PREV @ 2+ DR0 WRITE LOOP ; *TRANSFER FORGET TRANSFER ;S ( DOCUMENT A FILE ) : *DOCUMENT ( DOCUMENT THE FILE ) NAME CR ." T! DUP C@ ROT - SWAP C! ; ( SUBTRACT FROM CVAR ) ( : 2[ DUP 0= IF DROP 1 RAISE 2 TO TOS POWER ) ( ELSE 1 SWAP 0 DO 2 * LOOP ) ( THEN ; USED TO DETERMINE A RECORD' S ) O PRINTER " ?Y/N IF PRINT THEN CR DADRS @ 64 + 64 TYPE CR CR ( HEADING ) 0 SCRATCH ! IF DGTMAP CR DSKSZ 0 DO I FON? BM2 C@ 0 - IF I LIST 1 SCRATCH +! SCRATCH @ 3 MOD 0= IF NP THEN THEN LOOP  ( BIT NUMBER ) : DZONK BITMAP MAPSZ 0 FILL ; ( CLEAR BIT MAP ) : DGT DUP 8/ DUP ROT ROT 8* - SWAP DUP ROT 2[ ; ( TRANSLATES THE BLOCK # IN TOS TO BITPOSITION ) : DON DGT SWAP BITMAP + C@ ( SET A BLOCK TO 'ON' ) THEN NP TUBE ; ;S ( LOOKUP FNAME: EXIT TOS & BM1 = POSITION IN DIR, OR -1 ) : LOOKUP -1 BM1 C! DADRS @ 128 + N ! ( 1ST 4 LETTERS ) 13 0 DO ( ARE VALID IN FNAME ) N @ C@ 0 - IF N @ OR SWAP BITMAP + C! ; : DOFF DGT BM2 C! BITMAP + C@ ( SET A BLOCK 'OFF' ) 255 BM2 C@ - AND SWAP BITMAP + C! ; --> ( FORTHDOS PRIMITIVES ) : DON? 0 BM2 C! DUP DGT SWAP BITMAP + C@ AND SWAP DROP 0=  C@ FNAME C@ = IF N @ 1+ C@ FNAME 1+ C@ = IF N @ 2 + C@ FNAME 2 + C@ = IF N @ 3 + C@ FNAME 3 + C@ = IF I BM1 C! LEAVE THEN THEN  IF DROP ELSE BM2 C! THEN ; ( IF BLOCK# IN TOS IS USED, BM2=BLOCK #, ELSE BM2=0 ) 00 VARIABLE 1SB ( FIRST BLOCK IN THREAD ) : DNXT ( FIND NEXT FREE, CHECK THREAD INTEGRITY ) 0 BM1 C! DSKSZ 0 DO I DON? BM2 C@ 0= I THEN THEN THEN 64 N +! LOOP BM1 C@ ; --> ( FORTHDOS DEFINITIONS ) VOCABULARY DOS IMMEDIATE DOS DEFINITIONS --> ( FORTH DOS ) CR ." LOADING FORTH DOS" 1SB C@ > AND IF I BM1 C! LEAVE THEN LOOP ( GET BLOCK INTO BM2 ) BM2 C@ 0 - BM1 C@ 0= OR IF -1 BM2 C! CR ." ***** THREAD FULL ******" CR QUIT THEN ; --> ( ACCESS DIRECTORY THROUGH A VIRTUAL BUFFER ) : D CR : DOS ; 3 WIDTH ! 00 VARIABLE SCRATCH : BYTE.COMPARE ( STRING MATCHING ROUTINE ) ( INPUT -- ADDR STR-3, ADDR STR-2, MAX LENG-1 ) ( OUTPUT -- 1 IF STR3 > STR2, 0 IF NOT, -1 IF = ) DUP SCRATCH ! 1+ 0 DO OVER OVER ( DUP ADDR ) READ DADRS @ DIRBLK @ 1 R/W ; ( READ DIRECTORY ) : DWRITE DADRS @ DIRBLK @ 0 R/W ; ( WRITE DIRECTORY ) : DRD DADRS @ BITMAP MAPSZ CMOVE ; ( READ THE BITMAP ) : DWR BITMAP DADRS @ MAPSZ CMOVE ; ( SAVE THE BITMAP ) : MOUNT DZO     NK DREAD DRD ; ( MOUNT THE DISKETTE ) : DSAVE DWR DWRITE ; ( SAVE DIRECTORY ) : REMOVE DSAVE FLUSH ." DISKETTE" CR ; ( REMOVE ) : DINIT MOUNT DADRS @ 1024 0 FILL DZONK ; ( INIT DIR ) --> ( LOOKUP FNAME: EXIED BY THE FILE IN FNAME ) : FSIZE DGTMAP BM1 C@ -1 - IF 0 BM1 C! DSKSZ 0 DO I FON? BM2 C@ 0 > IF 1 BM1 C+! THEN LOOP BM1 C@ SPACE T# SPACE ." BLOT TOS & BM1 = POSITION IN DIR, OR -1 ) : LOOKUP -1 BM1 C! DADRS @ 128 + N ! ( 1ST 4 LETTERS ) 13 0 DO ( ARE VALID IN FNAME ) N @ FNAME 10 BYTE.COMPARE -1 = IF I BM1 C! LEAVE THEN 64 N CKS" THEN ; --> ( WRITE ) : WRITE ( WRITE BUFFER ON TOS TO THE FILE 'FNAME' ) N1 ! PROT? 0= IF DADD DUP 0 > ( DON'T WRITE IF REC IS PROTECTED ) IF N1 @ SWAP 0 R/W  +! LOOP BM1 C@ ; --> ( DPUTNM -- ADD A NEW FILENAME TO THE DIRECTORY ) : DPUTNM LOOKUP 255 - IF ." * FILE ALREADY EXISTS" QUIT ELSE DADRS @ 128 + N ! 13 0 DO N @ C@ 0 =  ELSE DROP THEN ELSE CR ." FILE IS WRITE PROTECTED" CR THEN ; --> ( RFIND -- RANDOM ACCESS OF RELATIVE BLOCK# ON TOS TO ) ( BUFFER AT TOS-2 ) : RFIND DUP N ! BM1 C! N1 ! DSKSZ 0 DO I FON?  IF FNAME N @ 15 CMOVE LEAVE 0 N ! ELSE 64 N +! THEN LOOP N @ 0 - IF ." * FILE NAME SPACE IS FULL" QUIT THEN THEN ; --> ( NAME -- OBTAIN NAME, DGTMA BM2 C@ 0 > ( LOOP TO FIND RELATIVE REC # ) IF 1 BM1 C-! BM1 C@ 0 > NOT IF I N ! LEAVE THEN THEN LOOP ; --> ( RREAD, RWRITE ) : RREAD (P -- OBTAIN FILEMAP ) : NAME FNAME 15 0 FILL SPACE ." FILENAME: " FNAME 15 EXPECT ; : DGTMAP ( OBTAIN THE FILEMAP FOR THE FILE NAMED IN FNAME ) LOOKUP 255 - IF DADRS @ 128 + BM1 C@ 64 * + 20 +  RAMDOM READ BLOCK# AT TOS TO BUFF AT TOS2 ) ( EXIT=1 IF OKAY ) RFIND BM1 C@ 0 > IF 0 ELSE N1 @ N @ 1 R/W 1 THEN ; : RWRITE ( RANDOM WRITE BLOCK# AT TOS TO BUFF AT TOS2 ) ( EXIT=1 IF OKAY ) ( NOTE THAT DUP N ! QMAP MAPSZ CMOVE THEN ; --> ( DADD -- ADD A BLOCK TO THREAD FOR 'FNAME' & LEAVE # ON TOS ) ( OR 0 ) : DADD DGTMAP DNXT BM2 C@ -1 - ( FIND BITMAP FOR ) IF BM1 C@ DUP DON DGT SWAP ( THIS FI USER MAY ONLY WRITE TO A BLOCK ALREADY ALLOCATED ) RFIND BM1 C@ 0 > IF 0 ELSE N @ PROT? 1 = IF DROP 0 ELSE N ! N1 @ N @ 0 R/W 1 THEN THEN ; --> ( PROTECT, UNPROTECLE, GET ) QMAP + C@ OR SWAP QMAP + C! ( NEXT IN CHAIN ) QMAP N @ MAPSZ CMOVE BM1 C@ ( PUT IT ON TOS ) ELSE 0 THEN ; --> ( 1STBLK, MAKE, FON? ) : FON? ( SEE IF THE FILE IN FT ) ( THESE WORDS ALTER THE WRITE PROTECT STATUS OF A FILE ) : PROTECT NAME LOOKUP 255 - IF RENM 170 N @ 63 + C! THEN ; : UNPROTECT NAME LOOKUP 255 - IF RENM 0 N @ 63 + C! THENMAP IS USING THE BLOCK # ) ( IN TOS ) DUP DGT SWAP QMAP + C@ AND SWAP DROP 0= IF DROP 0 BM2 C! ELSE BM2 C! THEN ; : 1STBK ( SET 1SB ) DGTMAP DSKSZ 0 DO I FON? BM2 C@ DU ; --> ( FREE -- PRINTS THE NUMBER OF FREE BLOCKS ON THE DISK ) : FREE 0 BM1 C! DSKSZ 0 DO I DON? BM2 C@ 0 > IF 1 BM1 C+! THEN LOOP CR DSKSZ BM1 C@ - T# SPACE ." FREE DISK BLOCKP 0 - IF 1SB C! LEAVE ELSE DROP THEN LOOP ; : (MAKE) 0 1SB C! DPUTNM 1STBK ; : MAKE ( MAKE A NEW FILE AND ALLOCATE SPACE FOR IT ) 0 1SB C! NAME DPUTNM 1STBK ; ( CREATE/OPEN A FILE ) --> ( RENM, KILL -- CALCULATE ADDRESS OF S" SPACE ." OUT OF" SPACE DSKSZ T# CR ; --> ( RUN, SCRLIST -- OUTPUT FILES ) : RUN NAME LOOKUP 255 - IF DGTMAP CR DSKSZ 0 DO I FON? BM2 C@ 0 - IF I LOAD THEN LOOP THEN CR ; --> : SHOWFILE, KILL A FILE ) : RENM DADRS @ 128 + BM1 C@ 64 * + N ! ; : PROT? ( RETURNS 1 IF THE FILE IS PROTECTED, 0 OTHERWISE ) LOOKUP 255 - IF RENM N @ 63 + C@ 170 = IF 1 ELSE 0 THEN THEN ; : KILL ( KILL THE FILE NAM ( LISTS THE FILENAME IN FNAME ) NAME LOOKUP 255 - IF DGTMAP CR DSKSZ 0 DO I FON? BM2 C@ 0 - IF I LIST THEN LOOP THEN CR ; --> ( FILES -- LISTS THE FILENAMES IN THE DIRECTORY ) : FILES DADRS @ 128ED IN FNAME ) LOOKUP 255 - IF PROT? 0= IF DGTMAP DSKSZ 0 DO I FON? BM2 C@ 0 - IF BM2 C@ DOFF THEN LOOP RENM N @ 64 0 FILL ELSE CR ." FILE IS PROTECTED" CR THEN  + N1 ! 26 EMIT ( CLEAR SCREEN ) 23 SPACES ." DISK DIRECTORY" CR CR DADRS @ 64 + 64 TYPE 0 BM3 C! CR ." ---------------------------------------" CR CR 13 0 DO N1 @ C@ 0 - IF N1 @ FNAME 15 CMOVE PROT? 1 =  ELSE CR ." DOES NOT EXIST" CR THEN ; : DELETE NAME KILL ; ( DELETE THE FILE ) --> ( READ -- READ THE NEXT BLOCK IN FNAME INTO THE BUFFER ) ( AT TOS ) : READ N1 ! DGTMAP BM1 C@ -1 - IF BEGIN NBLK @ DSKSZ >  IF ." *" ELSE SPACE THEN FNAME 10 TYPE FSIZE ( BM3 C@ 0= IF 1 BM3 C! 92 EMIT ) ( ELSE 0 BM3 C! CR THEN ) CR THEN 64 N1 +! LOOP CR ( PAD - T# SPACE ) FREE CR ; : ?Y/N ." Y/N? " KEY DUP IF 0 NBLK ! THEN 1 NBLK +! NBLK @ FON? BM2 C@ 0 - IF N1 @ BM2 C@ 1 R/W 1 ELSE 0 THEN UNTIL THEN ; --> ( FSIZE -- PRINT THE # OF BLOCKS US EMIT 89 = ; --> ( FORTHDOS UTILITIES ) : LOCK ( LOCKOUT ANY BLOCKS THE USER WISHES TO BE PROTECTED ) BEGIN ." BLOCK # TO BE LOCKED OUT " ( -1 IF NONE ) #IN DUP -1 = IF DROP 1 ELSE DON 0 T     HEN CR UNTIL ; --> ( SETDIR, SETUP NEW DIRECTORY VIA PROMPTS TO THE USER ) : SETDIR 26 EMIT ( CLEAR SCREEN ) ." NEW DIRECTORY" CR CR ." BUILD A NEW DIRECTORY ( & DESTROY ALL FILES ) " ?Y/N IF DINIT CR ." WRITE PROTECT BELOW BLOCK # " #IN 0 DO I DON LOOP CR LOCK FNAME 64 0 FILL DIRBLK @ DON DWR DADRS @ 64 + N ! ." DISKETTE DESCRIPTION: " FNAME 64 EXPECT FNAME N @ 64 CMOVE FNAME 64 0 FILL DSAVE THEN CR ; --> ( UTILITIES TRANSLATION ) : GAUX AUXBLK @ + LOAD ; : ?BLOCKS 0 GAUX ; : EDIT 1 GAUX ; : RENAME 2 GAUX ; : COPYALL 3 GAUX ; : FCOPY 4 GAUX ; : TRANSFER 5 GAUX ; : DOCUMENT  6 GAUX ; 32 WIDTH ! : --> ;S ; FORTH DEFINITIONS ;S --> --> ( RENAME -- GIVE AN OLD FILE A NEW NAME ) : RENAME SPACE BM1 C@ -2 -  IF ." OLD" NAME LOOKUP -1 = IF SPACE ." * NOT FOUND " QUIT ELSE RENM SPACE ." NEW" NAME FNAME N @ 15 CMOVE CR THEN ELSE LOOKUP 255 - IF @ FNAME SWAP 15 CMOVE THEN THEN ; -->  ( COPYALL -- COPY TOS BLOCKS OF THE FILE IN 'ONAME' > 'FNAME' ) : COPYALL 0 DO FNAME TMP 10 CMOVE ONAME FNAME 10 CMOVE BUFF READ TMP FNAME 10 CMOVE BUFF WRITE LOOP CR ONAME 10 TYPE ." COPIED TO "  ( VIRTUAL MEMORY DEFINITIONS ) CR ." VIRTUAL MEMORY" CR 00 VARIABLE BANK : VBLOCK ( VIRTUAL BLOCK # ) BANK @ 8 * ; : ADR ( CONVERT VIRTUAL ADDRESS TO REAL DISC BUFFER ADDRESS ) 0 B/BUF U/ VBLOCK + BLOCK + ; : C!-V ( S FNAME 10 TYPE CR ; --> ( FCOPY -- COPY ONE FILE TO ANOTHER ) : FCOPY ." COPY FROM" NAME LOOKUP -1 = IF ." * NO SUCH FILE" QUIT ELSE FSIZE BM1 C@ N1 ! FNAME ONAME 10 CMOVE SPACETORE BYTE TO VIRTUAL MEMORY ) ADR C! UPDATE ; : !-V ( STORE WORD TO VIRTUAL MEMORY ) >R SP@ 1+ C@ R 1+ C!-V R> C!-V ; --> ( VIRTUAL MEMORY DEFINITIONS ) : BOUNDS ( CALCULATE DO LOOP BOUNDS UTILITY ) OVER + SWAP ;  ." TO" NAME SPACE LOOKUP 255 = IF CR ." (NEW FILE)" DPUTNM N1 @ COPYALL ELSE CR ." (COPY OVER OLD FILE) " ?Y/N IF PROT? 0= IF KILL (MAKE) N1 @ COPYALL ELSE CR ." FILE IS WRITE PRO : C@-V ( FETCH BYTE FROM VIRTUAL MEMORY ) ADR C@ ; : @-V ( FETCH WORD FROM VIRTUAL MEMORY ) DUP >R C@-V R> 1+ C@-V SP@ 3 + C! ; : MOVE-V ( MOVE FROM VIRTUAL TO VIRTUAL MEMORY ) ( FROM-3, TO-2, COUNT-1TECTED" CR THEN THEN THEN THEN ; --> ( BLOCKS? -- PRINT # OF BLOCKS USED BY A GIVEN FILENAME ) : BLOCKS? NAME LOOKUP 255 - IF CR ." BLOCKS IN USE: " DSKSZ 0 DO I FON? BM2 C@ 0 -  ) BOUNDS DO DUP C@-V I C!-V 1+ LOOP DROP ; --> ( VIRTUAL MEMORY DEFINITIONS ) : +!-V ( INCREMENTED STORE TO VIRTUAL MEMORY ) DUP >R @-V + R> !-V ; : SAVE ( SAVE STRINGS TO VIRTUAL MEMORY )  IF I T# SPACE THEN LOOP THEN CR ; --> ( TRANSFER DRIVE B SCREENS TO FILE ) : TRANSFER CR ." GIVE DESTINATION " MAKE CR 1+ SWAP DO DR1 I LIST PREV @ 2+ DR0 WRITE  ( RAM FROM-3, VM TO-2, COUNT-1 ) BOUNDS DO DUP C@ I C!-V 1+ LOOP DROP ; : VM>RAM ( VIRTUAL MEMORY TO RAM STRING FETCH ) ( VM FROM-3, RAM TO-2, COUNT-1 ) BOUNDS DO DUP C@-V I C! 1+ LOOP DROP ; : TYPE- LOOP ; ;S FORTHBASREL)@ABLINK41 SUBCFORTHDOS$$$DEFGHIJKV ( TYPE TO LIST DEVICE FROM VIRTUAL MEMORY ) BOUNDS DO I C@-V EMIT LOOP ; --> --> ( VIRTUAL MEMORY DEFINITIONS ) : FILL-V ( FILL VIRTUAL MEMORY RANGE WITH CONSTANT )  ( ADDRESS-3, COUNT-2, BYTE CONSTANT-1 ) ROT ROT BOUNDS DO DUP I C!-V LOOP DROP ; ;S  ( VIRTUAL MEMORY DEFINITIONS ) : FILL-V ( FILL VIRTUAL MEMORY RANGE WITH CONSTANT )      ( **** PRINTER -- PRINTER INTERFACE W/ DIABLO ESC CODES PACKAGE **** ) ( UPDATED: 01/05/84 BY NAA ) ( PRINTER ENABLE, DISABLE ) HEX : PRINT ( ENABLE PRINTER ) 1 EPRINT C! ; ( WRITE 1 INTO ENABLE BYTE ) : TUBE ( DISABLE PRINTER ) 0 EPRINT C! ; ( WRITE 0 INTO ENABLE BYTE ) : ESC 1B EMIT ; ( ESCAPE CHARACTER ) : REST PRINT ESC 0D EMIT ." P" TUBE ; ( RESTORE PRINTER ) DECIMAL ( PRINTER DEFINITIONS ) ( FOR DIABLO PRINTERS ) : HT ( HORIZONTAL ABSOLUTE TAB ) ESC 09 EMIT ( STACK ) EMIT ; : VT ( VERTICAL ABSOLUTE TAB ) ESC 11 EMIT ( STACK ) EMIT ; HEX : LF 0A EMIT ; : BS 8 EMIT ; : NP 0C EMIT ; : FF 0C EMIT ( MULTIPLE DEF ) ; : HMI ( OUTPUT HMI ON STACK ) ESC 1F EMIT EMIT ; : VMI ( OUTPUT VMI ON STACK ) ESC 1E EMIT EMIT ; : RESET ESC 1A EMIT ." I" ; DEC( **** 4THCOMP -- CP/M WORDSTAR TEXT COMPILATION PACKAGE ********* ) ( UPDATED: 12/16/83 BY NAA ) HEXDUMP PKG DEBUG PKG POLYF PKG REMEMB PKGIMAL : NOR.HMIVMI ( SET 'NORMAL' HMI, VMI ) 13 HMI 9 VMI ; ;S  ESC 1F EMIT EMIT ; : VMI ( OUTPUT VMI ON STACK ) ESC 1E EMIT EMIT ; : RESET ESC 1A EMIT ." I" ; DEC( **** POLYF -- POLYFORTH TO FIG FORTH CONVERSION PACKAGE ********* ) ( UPDATED: 12/16/83 BY NAA ) ( PolyForth to Fig Forth conversion words) : NOT 0= ; ( Loads a group of disk blocks ) ( n1 n2 --> ) : THRU 1+ SWAP DO I LOAD LOOP ; : 2DROP DROP DROP ; ( Dummy text match word) ( addr1 count addr2 --> true ) : -TEXT 2DROP DROP 1 ( TRUE flag ) ; : ?DUP -DUP ; : 1- 1 - ; : 2- 2 - ; : EXIT R> DROP ;S ; ( Flushes all blocks to disk and loads last Edited screen ) : @LOAD FLUSH SCR @ LOAD ; ( Test block for binary - true = binary) ( block# --> flag ) : ?BINARY DROP 0 ( false ) ; ( Create a table named xxxx ) ( table:addr count --> ) ( xxx) : TABLE CREATE SMUDGE 0 DO , LOOP ; ( Position cursor ) ( x y --> ) : POS 126 EMIT 17 EMIT SWAP EMIT EMIT ; ( CLEAR SCREEN ) ( --> ) : CLS 126 EMIT 28 EMIT ; ( Ring Bell on console) ( --> ) : B( **** CASES -- FORTH 'CASES' PACKAGE ******************* ) ( UPDATED: 12/16/83 BY NAA ) 0 VARIABLE vCASE ( case value) CODE (DO-CASES) H POP vCASE SHLD NEXT JMP C; CODE (CASE) D POP vCASE LHLD L A MOV E CMP 0= IF ELL 7 EMIT ; ( Left and Right cursor commands) : LC 8 EMIT ; ( Left cursor ) : RC 16 EMIT ; ( Right cursor ) ;S H A MOV D CMP 0= IF B INX B INX NEXT JMP ENDIF ENDIF B LDAX C ADD A C MOV CS IF B INR ENDIF NEXT JMP C; CODE (ECASE) B LDAX A L MOV B INX B LDAX A H MOV H PUSH B POP NEXT JMP C; : DO-CASES COM     PILE (DO-CASES) 5 ; IMMEDIATE : CASE COMPILE (CASE) HERE 0 , 6 ; IMMEDIATE : ECASE 6 ?PAIRS COMPILE (ECASE) 0 , HERE OVER - SWAP ! HERE 2 - ; IMMEDIATE : END-CASES BEGIN ?STACK DUP 7 UEXTRN SWAP,SZERO,SPSTO,SPAT,STATE,SEMIS,STORE,SUBB,SEMIS,SPACE EXTRN TIB,TWO,TWOP,THREE,TDUP,TOR,TOGGL,TYPE EXTRN USTAR,UP,ULESS,USLAS EXTRN VOCL EXTRN WARN,WIDTH EXTRN XDO,XPLOO,XORR,XLOOP EXTRN ZEQU,ZLESS,ZBRAN,ZERO ; ASCII CHARACTERS US< 0= WHILE HERE SWAP ! REPEAT 5 - 19 ?ERROR ; IMMEDIATE : OTHERWISE ; IMMEDIATE ( The next word must be typed before saving image in CP/M) : REMEMBER [COMPILE] FORTH DEFINITIONS ( ED ; ABL EQU 20H ; SPACE ACR EQU 0DH ; CARRIAGE RETURN ADOT EQU 02EH ; PERIOD BELL EQU 07H ; (^G) BSIN EQU 08H ; INPUT BACKSPACE CHR = (^H)--MOD NAA BSOUT EQU 08H ; OUTPUT BACKSPACE (^H) DLE EQU 10H ; (^P) LF EQU 0AH ; LINE FEED FF EQU 0CH ; FORMNow save current pointers in "origin" TABLE ) HERE FENCE ! ( protect current DP ) LATEST 12 +ORIGIN ! ( top NFA ) HERE 28 +ORIGIN ! ( FENCE ) HERE 30 +ORIGIN ! ( DP )  FEED (^L) ; ; MEMORY ALLOCATION ; EM EQU 7A00H ; TOP OF MEMORY + 1 = LIMIT NSCR EQU 2 ; NUMBER OF 1024 BYTE SCREENS KBBUF EQU 1024 ; DATA BYTES PER DISK BUFFER US EQU 40H ; USER VARIABLES SPACE RTS EQU 0A0H ; RETURN STACK & TERM BUFF SPACE ; VOC-LINK 32 +ORIGIN ! ( VOC-LINK) DP @ 256 / BASE @ >R DECIMAL CR CR ." Save blocks = " . CR CR R> BASE ! ; ;S CO EQU KBBUF+4 ; DISK BUFFER + 2 HEADER + 2 TAIL NBUF EQU NSCR*400H/KBBUF ; NUMBER OF BUFFERS BUF1 EQU EM-CO*NBUF ; ADDR FIRST DISK BUFFER INITR0 EQU BUF1-US ; (R0) INITS0 EQU INITR0-RTS ; (S0) ; PAGE ;**************************************************************** ; ; ; START OF FORTH COMP SPECIAL WORDS ; ; ; ; CONCEIVED BY NICK AVDONIN 9/18/84 ; ; UPDATED: 9/18/84 ; ; ; ;**************************************************************** ; ************* ; * FPTR * ; ************* ; DB 84H ; FPTR ; ( FILE POINTER OF TLOAD ) DB 'FPT' DB 'R'+80H DW PAD-6 FPTR: DW DOVAR DW 0 ; ************** ; * ?TLOAD * ; ************** DB 86H ; ?TLOAD ; ( ARE WE TLOADING? ) DB '? TITLE '8080 FIG-FORTH 4THCOMP (09/18/84)' ;**************************************************************** ; ; ; 8080 FIG-FORTH 4THCOMP ; ; ; ; CONCEIVED BY NICK AVDONIN 09/18/84 ; ; UPDATED: 09/18/84 ; ; ; TLOA' DB 'D'+80H DW FPTR-7 QTLOAD: DW DOVAR DW 0 ; ; ; ************** ; * DBUFF1 * ; ************** DB 86H ; DBUFF1 ; ( DATA BUFFER #1 ) DB 'DBUFF' DB '1'+80H DW QTLOAD-9 DBUFF1: DW DOCON DW 29178 ; ; ************** ; * ; HI LEVEL CODE AND CP/M INTERFACE ; ; ; ;**************************************************************** ; ; RELEASE & VERSION NUMBERS ; FIGREL EQU 4 ; FIG RELEASE # FIGREV EQU 1 ; FIG REVISION # ;USRVER EQU 0 ; USER VERSION # ; ; DBUFF2 * ; ************** DB 86H ; DBUFF2 ; ( DATA BUFFER #2 ) DB 'DBUFF' DB '2'+80H DW DBUFF1-9 DBUFF2: DW DOCON DW 30206 ; ; ************ ; * WORD * ; ************ ; DB 84H ; WORD--MODIFIED FOR FORTH COMP BY NAA DB 'WO ALL PUBLICATIONS OF THE FORTH INTEREST GROUP ; ARE PUBLIC DOMAIN. THEY MAY BE FURTHER ; DISTRIBUTED BY THE INCLUSION OF THIS CREDIT ; NOTICE: ; ; THIS PUBLICATION HAS BEEN MADE AVAILABLE BY THE ; FORTH INTEREST GROUP ; P. O. BOX 1105 R' DB 'D'+80H DW DBUFF2-9 WORD: DW DOCOL DW QTLOAD DW AT DW ZEQU DW ZBRAN ; IF DW WORD4-$ ; DW BLK ; FOR FORTH COMP, ASSUME ONLY BLOCK 0 ; DW AT ; DW ZBRAN ; IF ; DW WORD1-$ ; DW BLK ; DW AT ; DW BLOCK ; DW BRAN ; ELSE ; DW WORD2-$; SAN CARLOS, CA 94070 ; PAGE ; GLOBAL SYMBOLS DEFINED GLOBAL CLD ; COLD START GLOBAL WRM ; WARM START GLOBAL TASK ; TOP MOST WORD IN FORTH VOC GLOBAL INITDP ; INITIAL DICTIONARY POINTER GLOBAL FORTH ; INITIAL VOCABULARY LIN WORD1: DW TIB DW AT ; ENDIF WORD3: DW BRAN ; ELSE DW WORD2-$ WORD4: DW DBUFF2 ; BUFFER 2, COMPILE RAM WORD2: DW INN DW AT DW PLUS DW SWAP DW ENCL DW HERE DW LIT DW 22H DW BLANK DW INN DW PSTOR DW OVER DW SUBB DW TOR DW K GLOBAL PEMIT ; PRINTER EMIT GLOBAL PKEY ; KEYBOARD GLOBAL PQTER GLOBAL PCR GLOBAL CREAT ; CREATE GLOBAL ERROR ; ERROR PROCESSING GLOBAL WORD GLOBAL QTLOAD GLOBAL NXTBLK ; EXTRN SYMBOLS REQUIRED EXTRN AT,ANDD,ALLOT EXTRN BASE,RR DW HERE DW CSTOR DW PLUS DW HERE DW ONEP DW FROMR DW CMOVE DW SEMIS ; ************ ; * MON * ; ************ ; DB 83H ; MON--RETURN TO DEBUG MONITOR DB 'MO' DB 'N'+80H DW WORD-7 MON: DW $+2 ; CODE DEFINITION JMP 38H BLK,BUILD,BRAN,BLANK,BL EXTRN CAT,CSLL,COMP,CURR,COMMA,CFA,CSTOR,CMOVE,CR,COUNT,CONT EXTRN DIGIT,DEC,DOES,DODOE,DMINU,DPLUS,DPL,DOVAR EXTRN DOCON,DP0,DDUP,DP,DTRAI,DPUSH,DOCOL,DROP,DUP EXTRN ENCL,EQUAL,EXEC EXTRN FROMR,FILL,FENCE EXTRN GREAT  JMP NEXT ; **************** ; * WARN * ; **************** ; DB 84H ; ISSUE WARNING OF UNDEFINED WORD DB 'WAR' DB 'N'+80H DW MON-6 WARNU: DW DOCOL DW CR DW HERE DW COUNT DW TYPE DW PDOTQ DB 33,' ? NOT DEFINED -- CONTIEXTRN HERE,HLD,HOLD,HPUSH EXTRN INN,IDO EXTRN LIT,LBRAC,LFA,LEAVE,LESS,LATES EXTRN MINUS EXTRN NEXT,NFA,NOOP EXTRN ORIG,ORR,OUTT,OVER,ONE,ONEP EXTRN PLUS,PAD,PFA,PSTOR,PDOTQ,PFIND EXTRN QERR,QUERY,QCOMP,QPAIR,QTERM EXTRN RR,ROT,RPP,RPSTO NUING... ' DW DROP,ZERO DW SEMIS ; ; ; **************** ; * WHERE * ; **************** ; DB 85H ; WHERE, PRINT COMPILIATION DB 'WHER' DB 'E'+80H DW WARNU-7 ; WHERE: DW DOCOL DW HERE DW ONEP DW CAT DW LIT DW 58 ; COLON       DW EQUAL DW ZBRAN DW WHERE1-$ DW CR DW PDOTQ DB 14,'COMPILING --> ' DW DBUFF2 DW INN,AT DW PLUS DW LIT DW 32 DW ENCL DW DROP,SWAP DW DROP,TYPE DW SPACE WHERE1: DW SEMIS ; ; ; **************** ; * SP.FIND * ; ********R DW XLOOP DW SCAN1-$ DW DBUFF2 DW LIT,600 DW PLUS DW LIT,80 DW OVER,PLUS DW SWAP DW XDO SCAN4: DW IDO DW CAT DW LIT,127 DW ANDD DW DUP DW LIT,20 DW LESS DW ZBRAN DW SCAN5-$ DW DROP DW ZERO,ZERO DW IDO ; INSERT END******** ; DB 87H ; SPECIAL FIND, FOR TLOAD DB 'SP.FIN' DB 'D'+80H DW WHERE-8 ; SPFIND: DW DOCOL DW BL DW WORD DW WHERE DW HERE,CONT DW AT,AT DW PFIND DW DUP DW ZEQU DW ZBRAN ; IF DW SPFIN1-$ DW DROP DW HERE DW LATES  COMPILATION DW ONEP,CSTOR DW IDO DW DBUFF2 DW SUBB DW FPTR,PSTOR DW LEAVE SCAN5: DW IDO DW CSTOR DW XLOOP,SCAN4-$ DW SEMIS ; ***************** ; * NXT.BLK * ; ***************** ; DB 87H ; FETCH NEXT DISK BLOCK DB 'DW PFIND ; ENDIF SPFIN1: DW SEMIS ; ; **************** ; * (NUMBER) * ; **************** ; DB 88H ; (NUMBER) DB '(NUMBER' DB ')'+80H DW SPFIND-10 PNUMB: DW DOCOL PNUM1: DW ONEP ; BEGIN DW DUP DW TOR DW CAT DW BASE DW AT DW DNXT.BL' DB 'K'+80H DW SCAN-13 NXTBLK: DW DOCOL DW QTLOAD,AT DW ZBRAN DW NXTBL1-$ DW FPTR,AT ; WE ARE TLOADING DW LIT,768 DW VMTRAM DW SCAN DW ZERO DW INN,STORE DW BRAN DW NXTBL2-$ NXTBL1: DW ONE DW BLK,PSTOR NXTBL2: DW SEMISIGIT DW ZBRAN ; WHILE DW PNUM2-$ DW SWAP DW BASE DW AT DW USTAR DW DROP DW ROT DW BASE DW AT DW USTAR DW DPLUS DW DPL DW AT DW ONEP DW ZBRAN ; IF DW PNUM3-$ DW ONE DW DPL DW PSTOR ; ENDIF PNUM3: DW FROMR DW BRAN ; ; ***************** ; * TLOAD * ; ***************** ; DB 85H ; BEGIN SPECIAL INTERPRET DB 'TLOA' DB 'D'+80H DW NXTBLK-10 TLOAD: DW DOCOL DW LIT,-1 DW WARN,STORE DW KEYTO DW POPEN DW ZERO DW FPTR,STORE DW INN,AT DW  REPEAT DW PNUM1-$ PNUM2: DW FROMR DW SEMIS ; ************** ; * NUMBER * ; ************** ; DB 86H ; NUMBER DB 'NUMBE' DB 'R'+80H DW PNUMB-0BH NUMB: DW DOCOL DW ZERO DW ZERO DW ROT DW DUP DW ONEP DW CAT DW LIT DW TOR DW ZERO DW INN,STORE DW ONE,QTLOAD DW STORE DW NXTBLK DW TINTER DW FROMR DW INN,STORE DW CR DW PDOTQ DB 20,'END TEXT COMPILATION' DW CR DW FCB DW ONEP DW LIT,35 DW ZERO,FILL DW ZERO,QTLOAD DW STORE DW ONE,WARN DW2DH DW EQUAL DW DUP DW TOR DW PLUS DW LIT DW -1 NUMB1: DW DPL ; BEGIN DW STORE DW PNUMB DW DUP DW CAT DW BL DW SUBB DW ZBRAN ; WHILE DW NUMB2-$ DW DUP DW CAT DW LIT DW 2EH DW SUBB DW ZERO DW QERR DW ZERO DW BR STORE DW SEMIS ; *************** ; * (ABORT) * ; *************** ; DB 87H ; (ABORT) DB '(ABORT' DB ')'+80H DW TLOAD-8 PABOR: DW DOCOL ; USER ABORT DW ZERO,QTLOAD DW STORE DW CR DW PDOTQ DB 17,'ABORTING COMPILE ' DW ONAN ; REPEAT DW NUMB1-$ NUMB2: DW DROP DW FROMR DW ZBRAN ; IF DW NUMB3-$ DW DMINU ; ENDIF NUMB3: DW SEMIS ; ************* ; * -FIND * ; ************* ; DB 85H ; -FIND (0-3) SUCCESS DB '-FIN' ; (0-1) FAILURE DB 'D'+80H DW NUMBE,WARN DW STORE DW ERROR DW SEMIS ; ************* ; * ERROR * ; ************* ; DB 85H ; ERROR DB 'ERRO' DB 'R'+80H DW PABOR-0AH ERROR: DW DOCOL DW WARN DW AT DW ZLESS DW ZBRAN ; IF DW ERRO1-$ DW PABOR ; ENDIF ERRO1:-9 DFIND: DW DOCOL DW BL DW WORD DW HERE DW CONT DW AT DW AT DW PFIND DW DUP DW ZEQU DW ZBRAN ; IF DW DFIN1-$ DW DROP DW HERE DW LATES DW PFIND ; ENDIF DFIN1: DW SEMIS ; **************** ; * SP.NUMBER * ; *********** DW HERE DW COUNT DW TYPE DW PDOTQ DB 2 DB '? ' DW MESS DW SPSTO ERRO2: DW QUIT ; *********** ; * ID. * ; *********** ; DB 83H DB 'ID' DB '.'+80H DW ERROR-8 IDDOT: DW DOCOL DW PAD DW LIT DW 20H DW LIT DW 5FH ***** ; DB 89H ; SPECIAL NUMBER PROCESS, FOR TLOAD DB 'SP.NUMBE' DB 'R'+80H DW DFIND-8 ; SPNUMB: DW DOCOL DW ZERO,ZERO DW ROT,DUP DW ONEP,CAT DW LIT,45 DW EQUAL DW DUP,TOR DW PLUS,PNUMB DW SWAP,DROP DW CAT DW BL,SUBB DW ZBRDW FILL DW DUP DW PFA DW LFA DW OVER DW SUBB DW PAD DW SWAP DW CMOVE DW PAD DW COUNT DW LIT DW 1FH DW ANDD DW TYPE DW SPACE DW SEMIS ; ************** ; * CREATE * ; ************** ; DB 86H DB 'CREAT' DB 'E'AN DW SPNUM1-$ DW WARNU SPNUM1: DW FROMR DW ZBRAN DW SPNUM2-$ DW MINUS SPNUM2: DW SEMIS ; ***************** ; * TINTERPRET * ; ***************** ; DB 8AH ; FOR TLOADING DB 'TINTERPRE' DB 'T'+80H DW SPNUMB-12 TINTER: DW D+80H DW IDDOT-6 CREAT: DW DOCOL DW DFIND DW ZBRAN ; IF DW CREA1-$ DW DROP DW NFA DW IDDOT DW LIT,4 DW MESS DW SPACE ; ENDIF CREA1: DW HERE DW DUP DW CAT DW WIDTH DW AT DW MIN DW ONEP DW ALLOT DW DUP DW LIT,0A0H DW OCOL TINTE1: DW SPFIND ; BEGIN DW ZBRAN ; IF DW TINTE2-$ DW STATE DW NOOP DW AT DW LESS DW ZBRAN ; IF DW TINTE3-$ DW CFA DW COMMA DW BRAN ; ELSE DW TINTE4-$ TINTE3: DW CFA DW EXEC ; ENDIF TINTE4: DW QSTAC DW BRAN ; ELSE DW TOGGL DW HERE DW ONE DW SUBB DW LIT,80H DW TOGGL DW LATES DW COMMA DW CURR DW AT DW STORE DW HERE DW TWOP DW COMMA DW SEMIS ; ***************** ; * [COMPILE] * ; ***************** ; DB 0C9H DB '[COMPILE' DB ']'+8TINTE5-$ TINTE2: DW HERE DW SPNUMB DW LITER TINTE7: DW QSTAC ; ENDIF TINTE5: DW BRAN ; AGAIN--NOTE: 'X' = NULL WORD EXITS LOOP DW TINTE1-$ ; ***************** ; * SCAN/AHEAD * ; ***************** ; DB 8AH ; PREPARE FOR COMPILE DB 0H DW CREAT-9 BCOMP: DW DOCOL DW DFIND DW ZEQU DW ZERO DW QERR DW DROP DW CFA DW COMMA DW SEMIS ; *************** ; * LITERAL * ; *************** ; DB 0C7H DB 'LITERA' DB 'L'+80H DW BCOMP-0CH LITER: DW DOCOL DW STA'SCAN/AHEA' DB 'D'+80H DW TINTER-13 SCAN: DW DOCOL DW DBUFF2 DW LIT,600 DW OVER,PLUS DW SWAP DW XDO SCAN1: DW IDO,CAT DW LIT,127 DW ANDD DW DUP DW BL,LESS DW ZBRAN DW SCAN2-$ DW DROP DW BL ; INSERT BLANK SCAN2: DW IDO,CSTOTE DW AT DW ZBRAN ; IF DW LITE1-$ DW COMP DW LIT DW COMMA ; ENDIF LITE1: DW SEMIS ; **************** ; * DLITERAL * ; **************** ; DB 0C8H DB 'DLITERA' DB 'L'+80H DW LITER-0AH DLITE: DW DOCOL DW STATE DW AT DW      ZBRAN ; IF DW DLIT1-$ DW SWAP DW LITER DW LITER ; ENDIF DLIT1: DW SEMIS ; ************** ; * ?STACK * ; ************** ; DB 86H DB '?STAC' DB 'K'+80H DW DLITE-0BH QSTAC: DW DOCOL DW SPAT DW SZERO DW AT DW SWAP DW ULE DW DRZER DW LIT,0 DW LIT,EPRINT DW STORE DW LIT,ORIG+12H DW LIT,UP DW AT DW LIT,6 DW PLUS DW LIT,16 DW CMOVE DW LIT,ORIG+0CH DW AT DW LIT,FORTH+6 DW STORE DW ABORT PAGE ; ************ ; * S->D * ; ************ ; SS DW ONE DW QERR DW SPAT DW HERE DW LIT DW 80H DW PLUS DW ULESS DW LIT DW 7 DW QERR DW SEMIS ; ***************** ; * INTERPRET * ; ***************** ; DB 89H DB 'INTERPRE' DB 'T'+80H DW QSTAC-9 INTER: DW DOCOL  DB 84H DB 'S->' DB 'D'+80H DW COLD-7 STOD: DW $+2 POP D LXI H,0 MOV A,D ANI 80H JZ STOD1 DCX H STOD1: JMP DPUSH ; ********** ; * +- * ; ********** ; DB 82H DB '+' DB '-'+80H DW STOD-7 PM: DW DOCOL DW ZLESS DW Z INTE1: DW DFIND ; BEGIN DW ZBRAN ; IF DW INTE2-$ DW STATE DW AT DW LESS DW ZBRAN ; IF DW INTE3-$ DW CFA DW COMMA DW BRAN ; ELSE DW INTE4-$ INTE3: DW CFA DW EXEC ; ENDIF INTE4: DW QSTAC DW BRAN ; ELSE DW INTE5-$ INTE2: DW HERBRAN ; IF DW PM1-$ DW MINUS ; ENDIF PM1: DW SEMIS ; *********** ; * D+- * ; *********** ; DB 83H DB 'D+' DB '-'+80H DW PM-5 DPM: DW DOCOL DW ZLESS DW ZBRAN ; IF DW DPM1-$ DW DMINU ; ENDIF DPM1: DW SEMIS ; ***********E DW NUMB DW DPL DW AT DW ONEP DW ZBRAN ; IF DW INTE6-$ DW DLITE DW BRAN ; ELSE DW INTE7-$ INTE6: DW DROP DW LITER ; ENDIF INTE7: DW QSTAC ; ENDIF INTE5: DW BRAN ; AGAIN DW INTE1-$ ; ***************** ; * IMMEDIATE * ; * ; * ABS * ; *********** ; DB 83H DB 'AB' DB 'S'+80H DW DPM-6 ABS: DW DOCOL DW DUP DW PM DW SEMIS ; ************ ; * DABS * ; ************ ; DB 84H DB 'DAB' DB 'S'+80H DW ABS-6 DABS: DW DOCOL DW DUP DW DPM D**************** ; DB 89H DB 'IMMEDIAT' DB 'E'+80H DW INTER-0CH IMMED: DW DOCOL DW LATES DW LIT DW 40H DW TOGGL DW SEMIS ; ****************** ; * VOCABULARY * ; ****************** ; DB 8AH DB 'VOCABULAR' DB 'Y'+80H DW SEMIS ; *********** ; * MIN * ; *********** ; DB 83H DB 'MI' DB 'N'+80H DW DABS-7 MIN: DW DOCOL,TDUP DW GREAT DW ZBRAN ; IF DW MIN1-$ DW SWAP ; ENDIF MIN1: DW DROP DW SEMIS ; *********** ; * MAX * ; *********** W IMMED-0CH VOCAB: DW DOCOL DW BUILD DW LIT DW 0A081H DW COMMA DW CURR DW AT DW CFA DW COMMA DW HERE DW VOCL DW AT DW COMMA DW VOCL DW STORE DW DOES DOVOC: DW TWOP DW CONT DW STORE DW SEMIS ; ************* ; *  ; DB 83H DB 'MA' DB 'X'+80H DW MIN-6 MAX: DW DOCOL,TDUP DW LESS DW ZBRAN ; IF DW MAX1-$ DW SWAP ; ENDIF MAX1: DW DROP DW SEMIS ; ********** ; * M* * ; ********** ; DB 82H DB 'M' DB '*'+80H DW MAX-6 MSTAR: DW DOCOL,FORTH * ; ************* ; DB 0C5H DB 'FORT' DB 'H'+80H DW VOCAB-0DH FORTH: DW DODOE DW DOVOC DW 0A081H DW TASK-7 ; COLD START VALUE ONLY ; CHANGED EACH TIME A DEF IS APPENDED ; TO THE FORTH VOCABULARY DW 0 ; END OF VOCABULARYTDUP DW XORR DW TOR DW ABS DW SWAP DW ABS DW USTAR DW FROMR DW DPM DW SEMIS ; ********** ; * M/ * ; ********** ; DB 82H DB 'M' DB '/'+80H DW MSTAR-5 MSLAS: DW DOCOL DW OVER DW TOR DW TOR DW DABS DW RR DW A LIST ; ******************* ; * DEFINITIONS * ; ******************* ; DB 8BH DB 'DEFINITION' DB 'S'+80H DW FORTH-8 DEFIN: DW DOCOL DW CONT DW AT DW CURR DW STORE DW SEMIS ; ********* ; * ( * ; ********* ; DB 0C1BS DW USLAS DW FROMR DW RR DW XORR DW PM DW SWAP DW FROMR DW PM DW SWAP DW SEMIS ; ********* ; * * * ; ********* ; DB 81H DB '*'+80H DW MSLAS-5 STAR: DW DOCOL DW MSTAR DW DROP DW SEMIS ; ************ ; * H DB '('+80H DW DEFIN-0EH PAREN: DW DOCOL DW LIT DW 29H DW WORD DW SEMIS ; ************ ; * QUIT * ; ************ ; DB 84H ; QUIT DB 'QUI' DB 'T'+80H DW PAREN-4 QUIT: DW DOCOL DW ZERO DW BLK DW STORE DW LBRAC QUIT /MOD * ; ************ ; DB 84H DB '/MO' DB 'D'+80H DW STAR-4 SLMOD: DW DOCOL DW TOR DW STOD DW FROMR DW MSLAS DW SEMIS ; ********* ; * / * ; ********* ; DB 81H DB '/'+80H DW SLMOD-7 SLASH: DW DOCOL DW SLMOD DW1: DW RPSTO ; BEGIN DW CR DW QUERY DW INTER DW STATE DW AT DW ZEQU DW ZBRAN ; IF DW QUIT2-$ DW PDOTQ DB 2 DB 'OK' ; ENDIF QUIT2: DW BRAN ; AGAIN DW QUIT1-$ ; ************* ; * ABORT * ; ************* ; DB 85H DB 'AB SWAP DW DROP DW SEMIS ; *********** ; * MOD * ; *********** ; DB 83H DB 'MO' DB 'D'+80H DW SLASH-4 MODD: DW DOCOL DW SLMOD DW DROP DW SEMIS ; ************* ; * */MOD * ; ************* ; DB 85H DB '*/MO' DB OR' DB 'T'+80H DW QUIT-7 ABORT: DW DOCOL DW SPSTO DW DEC DW QSTAC DW CR DW PDOTQ DB 0DH DB '4THCOMP V ' DB FIGREL+30H,ADOT,FIGREV+30H DW FORTH DW DEFIN DW QUIT PAGE ; WARM START ENTRY POINT ; WRM: LXI B,WRM1 JMP NEXT WR'D'+80H DW MODD-6 SSMOD: DW DOCOL DW TOR DW MSTAR DW FROMR DW MSLAS DW SEMIS ; ********** ; * */ * ; ********** ; DB 82H DB '*' DB '/'+80H DW SSMOD-8 SSLA: DW DOCOL DW SSMOD DW SWAP DW DROP DW SEMIS ; ********M1: DW WARM ; ************ ; * WARM * ; ************ ; DB 84H DB 'WAR' DB 'M'+80H DW ABORT-8 WARM: DW DOCOL DW ABORT ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; COLD START ENTRY POINT ; ; (EVERYTHING IS RESET) ; CLD: LXI B***** ; * M/MOD * ; ************* ; DB 85H DB 'M/MO' DB 'D'+80H DW SSLA-5 MSMOD: DW DOCOL DW TOR DW ZERO DW RR DW USLAS DW FROMR DW SWAP DW TOR DW USLAS DW FROMR DW SEMIS PAGE ;**************************************,CLD1 LHLD ORIG+12H SPHL JMP NEXT CLD1: DW COLD ; ************ ; * COLD * ; ************ ; DB 84H DB 'COL' DB 'D'+80H DW WARM-7 COLD: DW DOCOL ; DW FIRST ; NOT USED IN FORTH COMP ; DW USE,STORE ; DW FIRST ; DW PREV,STORE ;********** ; * ; CP/M INTERFACE * ; * ;************************************************ ; BDOS CONSTANTS FCBK EQU 5CH BDOSK EQU 5 DB 84H ; BDOS ; ( CP/M DOS ENTRY POINT ) DB 'BDO' DB 'S'+80H DW MSMOD-8 BDOSS: DW DO     CON DW 5 DB 86H ; OPENFC ; ( OPEN FILE CONSTANT ) DB 'OPENF' DB 'C'+80H DW BDOSS-7 OPENFC: DW DOCON DW 0FH DB 86H ; MAKEFC ; ( MAKE FILE CONSTANT ) DB 'MAKEF' DB 'C'+80H DW OPENFC-9 MAKEFC: DW DOCON DW 16H DB 86H ; REA QUIT ; NULL ENTRY KEYTO3: DW TFNAME DW BL,WORD DW HERE,ONEP DW CAT DW ZBRAN DW KEYTO4-$ DW TOEXT KEYTO4: DW SEMIS ; *************** ; * .NOFILE * ; *************** ; DB 87H DB '.NOFIL' DB 'E'+80H DW KEYTO-12 PNOFIL: DW DODFC ; ( READ FILE CONSTANT ) DB 'READF' DB 'C'+80H DW MAKEFC-9 READFC: DW DOCON DW 14H DB 83H ; FCB ; ( FILE CONTROL BLOCK ) DB 'FC' DB 'B'+80H DW READFC-9 FCB: DW DOCON DW 5CH DB 84H ; BUFF ; ( DEFAULT BUFFER ADDRESS ) COL ; PRINT NO FILE DW CR DW PDOTQ DB 17,'CANNOT FIND FILE ' DW FCBFN DW LIT DW 8 DW TYPE DW PDOTQ DB 1,'.' DW FCBFN DW LIT DW 8 DW PLUS DW LIT DW 3 DW TYPE DW QUIT DW SEMIS ; *************** ; * *OPEN * ; ** DB 'BUF' DB 'F'+80H DW FCB-6 BUFF: DW DOCON DW 80H DB 85H ; FCBDN ; ( DISK NAME ) DB 'FCBD' DB 'N'+80H DW BUFF-7 FCBDN: DW DOCON DW FCBK+0 DB 85H ; FCBFN ; ( FILE NAME ) DB 'FCBF' DB 'N'+80H DW FCBDN-8 FCBFN: DW DOCO************* ; DB 85H DB '*OPE' DB 'N'+80H DW PNOFIL-10 SOPEN: DW $+2 ; OPEN A FILE PUSH B ; SAVE INTERPRETIVE POINTER MVI C,15 JMP BDOSC ; FINISH DOS COMMAND ; *************** ; * (OPEN) * ; *************** ; DB 86H DBN DW FCBK+1 DB 85H ; FCBFT ; ( FILE TYPE ) DB 'FCBF' DB 'T'+80H DW FCBFN-8 FCBFT: DW DOCON DW FCBK+9 DB 85H ; FCBRL ; ( FILES CURRENT REEL ) DB 'FCBR' DB 'L'+80H DW FCBFT-8 FCBRL: DW DOCON DW FCBK+12 DB 85H ; FCBRC ;  '(OPEN' DB ')'+80H DW SOPEN-8 POPEN: DW DOCOL ; OPEN THE FILE IN FNAME DW FCB DW LIT DW 12 DW PLUS DW LIT DW 24 DW ZERO DW FILL DW SOPEN ; PRIMITIVE DW LIT DW 255 DW EQUAL DW ZBRAN DW POPEN1-$ DW PNOFIL ; CANNOT FIND ( FILES RECORD COUNT ) DB 'FCBR' DB 'C'+80H DW FCBRL-8 FCBRC: DW DOCON DW FCBK+15 DB 85H ; C.REC ; ( CURRENT RECORD ) DB 'C.RE' DB 'C'+80H DW FCBRC-8 CREC: DW DOCON DW FCBK+32 DB 85H ; R.REC ; ( RANDOM RECORD # ) DB 'R.R FILE POPEN1: DW SEMIS ; *************** ; * OPEN * ; *************** ; DB 84H DB 'OPE' DB 'N'+80H DW POPEN-9 OPEN: DW DOCOL ; ASK AND OPEN THE FILE DW KEYTO DW POPEN DW ZERO DW CREC DW CSTOR DW SEMIS ; **********E' DB 'C'+80H DW CREC-8 RREC: DW DOCON DW FCBK+33 ; IMPORTANT ENTRY FOR CP/M BDOSC: LXI D,FCBK ; FILE CONTROL BLOCK IN DE CALL BDOSK MVI D,0 MOV E,A POP B PUSH D ; ERROR CODE TO STACK JMP NEXT ; BACK TO FORTH ; ************** ; * *SETDMA * ; *************** ; DB 87H DB '*SETDM' DB 'A'+80H DW OPEN-7 SDMA: DW $+2 ; SET DMA POP D ; TAKE STACK ENTRY PUSH B ; SAVE INTERPRETIVE POINTER MVI C,26 CALL BDOSK ; CALL CP/M POP B JMP NEXT ; ********* ; * BDOSCMD * ; ************** ; DB 87H DB 'BDOSCM' DB 'D'+80H ; BDOS COMMAND CONSTANT ENTRY DW RREC-8 BDOSCMD: DW DOCON DW BDOSC ; ************** ; * DRA * ; ************** ; DB 83H DB 'DR' DB 'A'+80H ; SET DRIV*********** ; * *RREAD * ; *************** ; DB 86H DB '*RREA' DB 'D'+80H DW SDMA-10 SRREAD: DW $+2 ; RANDOM READ OF FILE PUSH B ; SAVE INTERPRETIVE POINTER MVI C,33 JMP BDOSC ; FINISH CP/M COMMAND ; *************** ; * E 'A' DW BDOSCMD-10 DRA: DW DOCOL DW ONE DW FCB DW CSTOR DW SEMIS ; ************** ; * DRB * ; ************** ; DB 83H DB 'DR' DB 'B'+80H ; SET DRIVE 'B' DW DRA-6 DRB: DW DOCOL DW TWO DW FCB DW CSTOR DW SEMIS  RREAD * ; *************** ; DB 85H DB 'RREA' DB 'D'+80H DW SRREAD-9 RREAD: DW DOCOL ; RANDOM READ OF FILE DW ZERO DW RREC DW TWO DW PLUS DW CSTOR DW RREC DW STORE DW SRREAD DW LIT DW 25 DW QERR DW SEMIS DB 83 ; ************** ; * >FNAME * ; ************** ; DB 86H DB '>FNAM' DB 'E'+80H DW DRB-6 TFNAME: DW DOCOL ; HERE TO FILE NAME DW FCBFN DW LIT DW 11 DW BL DW FILL ; BLANK OLD NAME DW HERE DW ONEP DW FCBFN DW HERE DW CATH ; POINTER DB 'PT' DB 'R'+80H DW RREAD-8 PTRV: DW DOVAR DW 0 ; *************** ; * 8IN * ; *************** ; DB 83H DB '8I' DB 'N'+80H DW PTRV-6 EIN: DW DOCOL ; READ IN 8 BLOCKS RANDOMLY DW ZERO DW PTRV DW STORE  DW LIT DW 8 DW MIN DW CMOVE ; WRITE NEW NAME DW SEMIS ; ************** ; * >EXT * ; ************** ; DB 84H DB '>EX' DB 'T'+80H DW TFNAME-9 TOEXT: DW DOCOL ; HERE TO FILE EXTENSION DW FCBFN DW LIT DW 8 DW PLUS  DW LIT DW 8 DW ZERO DW XDO EIN2: DW DBUFF1 DW PTRV DW AT DW PLUS DW SDMA DW SRREAD DW ONE DW RREC DW PSTOR DW ZBRAN DW EIN1-$ DW LEAVE EIN1: DW LIT DW 128 DW PTRV DW PSTOR DW XLOOP,EIN2-$ DW BUFF DW SDMA DW SEMI DW LIT DW 3 DW BL DW FILL ; BLANK OLD EXTENSION DW HERE DW ONEP DW FCBFN DW LIT DW 8 DW PLUS DW HERE DW CAT DW LIT DW 3 DW MIN DW CMOVE ; WRITE NEW EXTENSION DW SEMIS ; *************** ; * KEY>FNAME * ; ***********S DB 86H ; VARIABLE 'FROM.D' DB 'FROM.' DB 'D'+80H DW EIN-6 FROMD: DW DOVAR DW 0 DB 82H ; VARIABLE 'CT' DB 'C' DB 'T'+80H DW FROMD-9 CT: DW DOVAR DW 0 ; ****************** ; * VM>RAM * ; ****************** ; DB **** ; DB 89H DB 'KEY>FNAM' DB 'E'+80H DW TOEXT-7 KEYTO: DW DOCOL ; INPUT FNAME FROM KEYBOARD DW CR DW PDOTQ DB 25,'ENTER "FILENAME.EXT" --> ' DW QUERY DW TIB,AT DW ONEP,CAT DW LIT DW 58 DW EQUAL DW ZBRAN DW KEYTO1-$ DW 86H DB 'VM>RA' DB 'M'+80H DW CT-5 VMTRAM: DW DOCOL ; FROM DISK TO BUFFER DW CT DW STORE DW FROMD,STORE DW FROMD,AT DW ZERO DW LIT,128 DW USLAS DW SWAP DW DROP DW RREC DW STORE DW EIN ; READ INTO BUFFER DW DBUFF1 DW FROMTWO DW INN DW PSTOR DW TIB,AT DW CAT DW LIT DW 66 DW SUBB DW ZBRAN DW KEYTO2-$ DW DRA DW BRAN DW KEYTO1-$ KEYTO2: DW DRB ; ELSE KEYTO1: DW LIT DW 46 DW WORD DW HERE DW ONEP DW CAT DW ZEQU DW ZBRAN DW KEYTO3-$ DWD,AT DW ZERO DW LIT,128 DW USLAS DW DROP DW PLUS DW DBUFF2 DW CT,AT DW CMOVE DW SEMIS ; *************** ; * MESSAGE * ; * NEW * ; *************** ; ERRSTR: DB 'ERROR TXT' ; ERROR.TXT IS FILE NAME DB 87H DB 'ME     SSAG' DB 'E'+80H DW VMTRAM-9 MESS: DW DOCOL DW WARN DW AT DW ZBRAN ; IF DW MESS1-$ DW FCB ; DISK IS AVAILABLE DW PAD DW LIT,36 DW CMOVE DW FCB,ONEP DW LIT,35 DW ZERO,FILL DW LIT,ERRSTR DW FCBFN DW LIT,11 DW CMOVE DW SOPB ; SAVE (IP) MVI C,ACR ; OUTPUT (CR) TO CONSOLE CALL CPOUT ; & MAYBE TO PRINTER MVI C,LF ; OUTPUT (LF) TO CONSOLE CALL CPOUT ; & MAYBE TO PRINTER POP B ; RESTORE (IP) JMP NEXT ; ;---------------------------------------------------- PAGE ;EN DW LIT,255 DW EQUAL DW ZBRAN ; IF DW MESS4-$ DW PDOTQ DB 6,'MSG # ' DW DOT DW BRAN DW MESS5-$ MESS4: DW DUP,TWO DW SLASH DW RREAD DW ONE,ANDD DW ZBRAN ; IF DW MESS6-$ DW BUFF DW LIT,64 DW PLUS DW BRAN DW MESS7-$ M DB 0C1H ; ' ( TICK ) DB 0A7H DW EPRT-9 TICK: DW DOCOL DW DFIND DW ZEQU DW ZERO DW QERR DW DROP DW LITER DW SEMIS ; DB 86H ; FORGET DB 'FORGE' DB 'T'+80H DW TICK-4 FORG: DW DOCOL DW CURR DW AT DW CONT DW AT DW SUBB ESS6: DW BUFF MESS7: DW LIT,64 DW DTRAI DW TYPE DW SPACE MESS5: DW PAD,FCB DW LIT,36 DW CMOVE MESS1: DW BRAN ; ELSE NO DISK ." MSG" DW MESS8-$ DW PDOTQ DB 6,'MSG # ' DW DOT MESS8: DW SEMIS PAGE ;---------------------------------- DW LIT DW 18H DW QERR DW TICK DW DUP DW FENCE DW AT DW LESS DW LIT DW 15H DW QERR DW DUP DW NFA DW DP DW STORE DW LFA DW AT DW CONT DW AT DW STORE DW SEMIS ; DB 84H ; BACK DB 'BAC' DB 'K'+80H DW FORG-9 BA-------- ; ; 8080 PORT FETCH AND STORE ; ( SELF MODIFYING CODE, NOT REENTRANT ) ; DB 82H ; P@ "PORT @" DB 'P' DB '@'+80H DW MESS-0AH PTAT: DW $+2 POP D ;E <- PORT# LXI H,$+5 MOV M,E IN 0 ;( PORT# MODIFIED ) MOV L,A ;L <- (PORT#) MVCK: DW DOCOL DW HERE DW SUBB DW COMMA DW SEMIS ; DB 0C5H ; BEGIN DB 'BEGI' DB 'N'+80H DW BACK-7 BEGIN: DW DOCOL DW QCOMP DW HERE DW ONE DW SEMIS ; DB 0C5H ; ENDIF DB 'ENDI' DB 'F'+80H DW BEGIN-8 ENDIFF: DW DOCOL DW QCOI H,0 JMP HPUSH ; DB 82H ; "PORT STORE" DB 'P' DB '!'+80H DW PTAT-5 PTSTO: DW $+2 POP D ;E <- PORT# LXI H,$+7 MOV M,E POP H ;H <- CDATA MOV A,L OUT 0 ;( PORT# MODIFIED ) JMP NEXT PAGE ;----------------------------------------MP DW TWO DW QPAIR DW HERE DW OVER DW SUBB DW SWAP DW STORE DW SEMIS ; DB 0C4H ; THEN DB 'THE' DB 'N'+80H DW ENDIFF-8 THEN: DW DOCOL DW ENDIFF DW SEMIS ; DB 0C2H ; DO DB 'D' DB 'O'+80H DW THEN-7 DO: DW DOCOL DW COM--------- ; ; CP/M CONSOLE & PRINTER INTERFACE ; ; CP/M BIOS CALLS USED ; ( NOTE: BELOW OFFSETS ARE 3 LOWER THAN CP/M ; DOCUMENTATION SINCE BASE ADDR = BIOS+3 ) ; KCSTAT EQU 3 ; CONSOLE STATUS KCIN EQU 6 ; CONSOLE INPUT KCOUT EQU 9 ; CONSOLE OUP DW XDO DW HERE DW THREE DW SEMIS ; DB 0C4H ; LOOP DB 'LOO' DB 'P'+80H DW DO-5 LOOP: DW DOCOL DW THREE DW QPAIR DW COMP DW XLOOP DW BACK DW SEMIS ; DB 0C5H ; +LOOP DB '+LOO' DB 'P'+80H DW LOOP-7 PLOOP: DW DOCOL DWTPUT KPOUT EQU 0CH ; PRINTER OUTPUT ; ; ************* ; * EPRINT * ; ************* ; DB 86H ; ENABLE PRINTER VARIABLE DB 'EPRIN' DB 'T'+80H DW PTSTO-5 EPRT: DW DOVAR EPRINT: DW 0 ; ENABLE PRINTER VARIABLE ; ; 0 = DISABLED, 1 = E THREE DW QPAIR DW COMP DW XPLOO DW BACK DW SEMIS ; DB 0C5H ; UNTIL DB 'UNTI' DB 'L'+80H DW PLOOP-8 UNTIL: DW DOCOL DW ONE DW QPAIR DW COMP DW ZBRAN DW BACK DW SEMIS ; DB 0C3H ; END DB 'EN' DB 'D'+80H DW UNTIL-8 ENNABLED ; ; ; CP/M INTERFACE ROUTINES ; ; SERVICE REQUEST ; IOS: LHLD 1 ;(HL) <- BIOS TABLE ADDR+3 DAD D ; + SERVICE REQUEST OFFSET PCHL ; EXECUTE REQUEST ; RET FUNCTION PROVIDED BY CP/M ; ; BELOW BIOS CALLS USE 'IOS' ; CSTAT: PUSH B ; CDD: DW DOCOL DW UNTIL DW SEMIS ; DB 0C5H ; AGAIN DB 'AGAI' DB 'N'+80H DW ENDD-6 AGAIN: DW DOCOL DW ONE DW QPAIR DW COMP DW BRAN DW BACK DW SEMIS ; DB 0C6H ; REPEAT DB 'REPEA' DB 'T'+80H DW AGAIN-8 REPEA: DW DOCOL DW TOONSOLE STATUS LXI D,KCSTAT ; CHECK IF ANY CHR HAS BEEN TYPED CALL IOS POP B ; IF CHR TYPED THEN (A) <- 0FFH RET ; ELSE (A) <- 0 ; ; CHR IGNORED ; CIN: PUSH B ; CONSOLE INPUT LXI D,KCIN ; WAIT FOR CHR TO BE TYPED CALL IOS ; (A) <- CHR, (MR DW TOR DW AGAIN DW FROMR DW FROMR DW TWO DW SUBB DW ENDIFF DW SEMIS ; DB 0C2H ; IF DB 'I' DB 'F'+80H DW REPEA-9 IFF: DW DOCOL DW COMP DW ZBRAN DW HERE DW ZERO DW COMMA DW TWO DW SEMIS ; DB 0C4H ; ELSE DB 'ELS'SB) <- 0 POP B RET ; COUT: PUSH H ; CONSOLE OUTPUT LXI D,KCOUT ; WAIT UNTIL READY CALL IOS ; THEN OUTPUT (C) POP H RET ; POUT: LXI D,KPOUT ; PRINTER OUTPUT CALL IOS ; WAIT UNTIL READY RET ; THEN OUTPUT (C) ; CPOUT: PUSH B CALL COUT DB 'E'+80H DW IFF-5 ELSEE: DW DOCOL DW TWO DW QPAIR DW COMP DW BRAN DW HERE DW ZERO DW COMMA DW SWAP DW TWO DW ENDIFF DW TWO DW SEMIS ; DB 0C5H ; WHILE DB 'WHIL' DB 'E'+80H DW ELSEE-7 WHILE: DW DOCOL DW IFF DW TW ; OUTPUT (C) TO CONSOLE POP B XCHG LXI H,EPRINT MOV A,M ; IF (EPRINT) <> 0 ORA A JZ CPOU1 CALL POUT CPOU1: RET ; ; FORTH TO CP/M SERIAL IO INTERFACE ; PQTER: CALL CSTAT ; IF CHR TYPED LXI H,0 ORA A JZ PQTE1 INR L ; THEN (S1) <- OP DW SEMIS ; DB 86H ; SPACES DB 'SPACE' DB 'S'+80H DW WHILE-8 SPACS: DW DOCOL DW ZERO DW MAX DW DDUP DW ZBRAN ; IF DW SPAX1-$ DW ZERO DW XDO ; DO SPAX2: DW SPACE DW XLOOP ; LOOP ENDIF DW SPAX2-$ SPAX1: DW SEMIS ; DB 82H TRUE PQTE1: JMP HPUSH ; ELSE (S1) <- FALSE ; PKEY: CALL CIN ; READ CHR FROM CONSOLE CPI DLE ; IF CHR = (^P) MOV E,A JNZ PKEY1 LXI H,EPRINT ; THEN TOGGLE (EPRINT)LSB MVI E,ABL ; CHR <- BLANK MOV A,M XRI 1 MOV M,A PKEY1: MOV L,E MVI H,; <# DB '<' DB '#'+80H DW SPACS-9 BDIGS: DW DOCOL DW PAD DW HLD DW STORE DW SEMIS ; DB 82H ; #> DB '#' DB '>'+80H DW BDIGS-5 EDIGS: DW DOCOL DW DROP DW DROP DW HLD DW AT DW PAD DW OVER DW SUBB DW SEMIS ; DB 84H ;0 JMP HPUSH ; (S1)LB <- CHR ; PEMIT: DW $+2 ; (EMIT) ORPHAN POP H ; (L) <- (S1)LB = CHR PUSH B ; SAVE (IP) MOV C,L CALL CPOUT ; OUTPUT CHR TO CONSOLE ; ; & MAYBE PRINTER POP B ; RESTORE (IP) JMP NEXT ; PCR: DW $+2 ; (CR) ORPHAN PUSH  SIGN DB 'SIG' DB 'N'+80H DW EDIGS-5 SIGN: DW DOCOL DW ROT DW ZLESS DW ZBRAN ; IF DW SIGN1-$ DW LIT DW 2DH DW HOLD ; ENDIF SIGN1: DW SEMIS ; DB 81H ; # DB '#'+80H DW SIGN-7 DIG: DW DOCOL DW BASE DW AT DW MSMOD DW ROT        DW LIT DW 9 DW OVER DW LESS DW ZBRAN ; IF DW DIG1-$ DW LIT DW 7 DW PLUS ; ENDIF DIG1: DW LIT DW 30H DW PLUS DW HOLD DW SEMIS ; DB 82H ; #S DB '#' DB 'S'+80H DW DIG-4 DIGS: DW DOCOL DIGS1: DW DIG ; BEGIN DW OVER DW OVER DW ORR DW ZEQU DW ZBRAN ; UNTIL DW DIGS1-$ DW SEMIS ; DB 83H ; D.R DB 'D.' DB 'R'+80H DW DIGS-5 DDOTR: DW DOCOL DW TOR DW SWAP DW OVER DW DABS DW BDIGS DW DIGS DW SIGN DW EDIGS DW FROMR DW OVER DW SUBB DW SPACS DW TYPE DW SEMIS ; DB 82H ; .R DB '.' DB 'R'+80H DW DDOTR-6 DOTR: DW DOCOL DW TOR DW STOD DW FROMR DW DDOTR DW SEMIS ; DB 82H ; D. DB 'D' DB '.'+80H DW DOTR-5 DDOT: DW DOCOL DW ZERO DW DDOTR DW SPACE DW SEMIS ; DB 81H ; . DB '.'+80H DW DDOT-5 DOT: DW DOCOL DW STOD DW DDOT DW SEMIS ; DB 81H ; ? DB '?'+80H DW DOT-4 QUES: DW DOCOL DW AT DW DOT DW SEMIS ; DB 82H ; U. DB 'U' DB '.'+80H DW QUES-4 UDOT: DW DOCOL DW ZERO DW DDOT  DW SEMIS ; DB 85H ; VLIST DB 'VLIS' DB 'T'+80H DW UDOT-5 VLIST: DW DOCOL DW LIT DW 80H DW OUTT DW STORE DW CONT DW AT DW AT VLIS1: DW OUTT ; BEGIN DW AT DW CSLL DW GREAT DW ZBRAN ; IF DW VLIS2-$ DW CR DW ZERO DW OUTT DW STORE ; ENDIF VLIS2: DW DUP DW IDDOT DW SPACE DW SPACE DW PFA DW LFA DW AT DW DUP DW ZEQU DW QTERM DW ORR DW ZBRAN ; UNTIL DW VLIS1-$ DW DROP DW SEMIS ; ;------ EXIT CP/M ----------------------- ; DB 83H ; BYE DB 'BY' DB 'E'+80H DW VLIST-8 BYE: DW $+2 JMP 0 ;----------------------------------------------- PAGE ; ******************************* ; *** "NEXT" CONSTANT *** ; ******************************* ; ; USED BY THE ASSEMBLER EXTENSION ; DB 84H ; NEXT DB 'NEX' DB 'T'+80H DW BYE-6 NNEXT: DW DOCON DW NEXT ; ********************** ; *** "TASK" *** ; ********************** ; ; THE LAST WORD IN THE DICTIONARY ; DB 84H ; TASK DB 'TAS' DB 'K'+80H DW NNEXT( **** ERROR -- FORTH ERROR MESSAGE DISPLAY USING CP/M PACKAGE **** ) ( UPDATED: 12/16/83 BY NAA ) ( NEW CP/M ERROR MESSAGE PRINTER ) 00 VARIABLE ERROR.STRING -2 ALLOT HEX 45 C, 52 C, 52 C, 4F C, 52 C, 20 C, 20 C, 20 C, 54 C, 58 C, 54 C,-7 TASK: DW DOCOL DW SEMIS ; INITDP: ; DS EM-$ ;CONSUME MEMORY TO LIMIT ; PAGE ; ; MEMORY MAP ; ( THE FOLLOWING EQUATES ARE NOT REFERENCED ELSEWHERE ) ; ; LOCATION CONTENTS ; -------- -------- ;MCOLD EQU ORIG ;JMP TO COLD START ;MWARM ( ERROR TXT IN ASCII ) DECIMAL : NMESSAGE ( NEW MESSAGE PRINT ) WARNING @ IF ( DISC AVAILABLE ) FCB PAD 36 CMOVE FCB 1+ 35 0 FILL ERROR.STRING FCBFN 11 CMOVE *OPEN 255 = IF ." MSG # " . ELSE DUP 2 / RREAD 1 AND IF B EQU ORIG+4 ;JMP TO WARM START ;MA2 EQU ORIG+8 ;COLD START PARAMETERS ;MUP EQU UP ;USER VARIABLES' BASE 'REG' ;MRP EQU RPP ;RETURN STACK 'REGISTER' ; ;MDPUSH EQU DPUSH ;ADDRESS INTERPRETER ;MHPUSH EQU HPUSH ;MNEXT EQU NEXT ; ;MDP0 EQU DP0 ;SUFF 64 + ELSE BUFF THEN 64 -TRAILING TYPE SPACE THEN PAD FCB 36 CMOVE ELSE ." MSG # " . THEN ; ( RE-WRITE OLD WORD ) HEX ' MESSAGE CONSTANT OLDMESSAGE ' NMESSAGE 2 - CONSTANT NEWMESSAGE : XX NEWMESTART FORTH DICTIONARY ;MDIO EQU DRIVE ;CP/M DISK INTERFACE ;MCIO EQU EPRINT ;CONSOLE & PRINTER INTERFACE ;MIDP EQU INITDP ;END INITIAL FORTH DICTIONARY ; = COLD (DP) VALUE ; = COLD (FENCE) VALUE ; | NEW ; | DEFINITIONS SAGE OLDMESSAGE ! 04F1 OLDMESSAGE 2+ ! ; XX FORGET OLDMESSAGE DECIMAL ;S " . THEN ; ( RE-WRITE OLD WORD ) HEX ' MESSAGE CONSTANT OLDMESSAGE ' NMESSAGE 2 - CONSTANT NEWMESSAGE : XX NEWMES; V ; ; ^ ; | DATA ; | STACK ;MIS0 EQU INITS0 ; = COLD (SP) VALUE = (S0) ; = (TIB) ; | TERMINAL INPUT ; | BUFFER ; V ; ; ^ ; | RETURN ; | STACK ;MIR0 EQU INITR0 ;START USER VARIABLES ; = COLD (RP) VALUE = (R0) ; = (UP) ; ;END USER VARIABLES ;MFIRST EQU BUF1 ;START DISK BUFFERS ; = FIRST ;MEND EQU EM-1 ;END DISK BUFFERS ;MLIMIT EQU EM ;LAST MEMORY LOC USED + 1 ; = LIMIT ; ; END !     s thru the dictionary for a CFA match) ( CFAddr --> CFAddr false ) ( CFA --> NFAddr true ) : TRAV CONTEXT @ @ ( Returns TRUE if match found!) BEGIN DUP >R PFA CFA OVER = IF DROP R> 1 1 ELSE R>  PFA LFA @ DUP 0= IF ( unknown word ) DROP 0 1 ELSE 0 THEN THEN UNTIL ; ( Tab to position "n" on current line: 0 to 79) ( n --> ) : TAB OUT @ - DUP 0 > I( **** STACK -- FORTH EXTRA STACK CONTROL WORDS PACKAGE ********* ) ( UPDATED: 12/16/83 BY NAA ) ( Stack list words: ?PICK PICK .S, BYE SLIST ) ( Pick number "n" from the parameter stack ) ( nx --> n1 f ) : ?PICK 2 * SP@ + DUPF SPACES ELSE DROP THEN ; ( Outputs ASCII character "c", "n" number of times to console) : ASC ( n c --> ) SWAP 0 DO DUP EMIT LOOP DROP ; ( Make a literal out of the ASCII character following ) ( Works in either compil @ SWAP 2+ S0 @ > DUP IF ( not enough on stack) SWAP DROP THEN ; ( Pick a number from the stack, Error #1 if not found) : PICK ?PICK 1 ?ERROR ; ( Prints stack contents without cr/lf's) : .S 11 ( # of values to print) DUe or execution modes. >>A T ) : >>A BL WORD HERE 1+ C@ [COMPILE] LITERAL ; IMMEDIATE ( **** TRACE -- FORTH TRACE DEBUG ROUTINE PACKAGE ********* ) ( Get level number of Return Stack: 0 to 9) ( addr --> n ) : RSLEVEL R0 @ SWAP -P >R ( save count) 1 DO I ?PICK IF LEAVE ELSE . THEN LOOP R> ?PICK IF ." << " ELSE DROP THEN ; : BYE CR ." Insert CP/M boot disk and press ESCape key" KEY CR 27 = IF BYE THEN CR ; ;S  2 / 3 - 99 MIN ; ( Store Return stack level from ASCII character on stack) : STORE-LEVEL DUP TLCHAR ! >>A 0 - 2 * R0 @ 6 - SWAP - XRP 6 + ! ; ( --> n ) ( Print trace legend on console ) ( --> ) : PRINT-LEGEND CR CR ." TLV RS IP CFA Name " ." Stack contents (top <--)" CR 63 >>A - ASC CR ; ( Trace words continued) : TEST-CHAR DO-CASES ( c1 c1 --> c2 ) 27 CASE DROP >>A # ( ESCape ) ECASE >>A S CASE 1 TMODE ! ( Step ) ECASE >>A C CASE 0 TMODE ! ( Trace ) ECASE >>A R CASE 0 XRP 8 + ! ( Run ) ECASE OTHERWISE DROP TLCHAR @ ( last char )  END-CASES ; ( Get trace level: from operator ) ( -- f ) ( f=0 to abort) : GET-TLEVEL ( 0 ... ? = level, ESCape = abort ) 13 EMIT ( cr) ." (" KEY DUP DUP >>A 0 >>A ? WITHIN IF STORE-LEVEL ( 0 thru ? ) ELSE TEST-CHAR THEN DUP EMIT ( echo char) >>A # - ; ( Print one trace line: RS level, IP, CFA, name, stack values) : PRINT-TLINE OUT @ IF CR CR THEN ." (?) " XRP @ RSLEVEL 2 .R 2 SPACES ( print Ret Stack level) XRP 2+ @ DUP 4HEX 1 SPACES ( print IP ) @ DUP 4HEX 1 SPACES ( print CFA ) TRAV ( do word search) IF ID. ELSE ." ??? " DROP THEN 39 TAB ?STACK ( test stack) .S ( print stack contents) ;( **** TRACE -- FORTH TRACE DEBUG ROUTINE PACKAGE ********* ) ( UPDATED: 12/19/83 BY NAA ) ( ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ) ( ; ; ) ( ; F O R T H T R A C E  ( **** TRACE -- FORTH TRACE DEBUG ROUTINE PACKAGE ********* ) ( Debug routine comes here to print on trace line and input new trace level from operator) ( --> ) : (DOTRACE) HERE XDP ! HLD @ XHLD ! 200 ALLOT ( move PAD) BASE @ X ; ) ( ; ; ) ( ; P R O G R A M Ver 1.0 ; ) ( ; ; ) ( ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ) DEBUG-VOC DEFINITIONS BASE ! NBASE @ BASE ! PRINT-TLINE TMODE @ ?TERMINAL OR IF GET-TLEVEL ELSE 1 THEN CR XDP @ DP ! XHLD @ HLD ! XBASE @ BASE ! IF TRACE-NEXT ( continue tracing) THEN CR ." Trace Aborted by operator" C 0 VARIABLE TLCHAR ( Last Trace Level Character ) 0 VARIABLE TMODE ( Trace mode: 0=continious, 1=step) 0 VARIABLE XDP ( *** ) 0 VARIABLE XHLD ( save values) 0 VARIABLE XBASE ( *** ) 0 VARIABLE NBASE ( Bases ) ( 'TRAV' lookR QUIT ; ' (DOTRACE) CFA XRP 10 + ! ( patch address) ( Main TRACE routine ) : STEP/TRACE R> DROP ( tmode --> ) ( name ) BASE @ NBASE ! ( save BASE ) TMODE ! ( and mode ) [COMPILE] ' ( search"      for word) CFA DEBUG-VOC PRINT-LEGEND 48 TLCHAR ! TEXECUTE ( do the trace) ;TRACE ( end trace) CR ." Trace completed" CR ; FORTH DEFINITIONS ( Examples: STEP name -or- TRACE name ) : STEP  : INTERPRET ( NOTE: SINGLE NUMBERS ONLY ) BEGIN ( FIND WORD DEFINITION ) SP.FIND IF STATE @ < IF CFA , ( COMPILE ) ELSE CFA EXECUTE THEN ?STACK ELSE ( TRY A NUMBER CONVERSION ) HERE SP.NUMBER [COMPILE] LITERAL ?STACK DEBUG-VOC 1 STEP/TRACE ; ( Step tracing ) : TRACE DEBUG-VOC 0 STEP/TRACE ; ( Continous tracing ) FORTH ;S  THEN AGAIN ( NOTE: 'X'= NULL WORD EXITS LOOP ) ; : SCAN/AHEAD ( PREPARE COMPILE.RAM ) COMPILE.RAM 600 OVER + SWAP DO I C@ 127 AND DUP 32 < IF ( CONTROL ) DROP 32 ( INSERT BLANK ) THEN I C! LOOP ( NOW SCAN REMNANT ) COMPILE.RAM 600 + 80 OVER + SWAP DO I C@ 127 AND DUP 20 < IF DROP 0 0 ( INSERT END COMPILATION ) I 1+ C! I COMPILE.RAM - F.PTR +! LEAVE THEN I C! LOOP ; : NEXT.BLK ( DISK ACCESS OF NEXT BLOCK OF DATA ) ?TLOAD @ IF ( WE ARE 'TLOADING ) F.PTR @ 768 VM>RAM SCAN/AHEAD ( PREPARE RAM ) 0 IN ! ELSE ( NORMAL ) 1 BLK +! THEN ; : TLOAD ( INITIATE LOADING OF CP/M TEXT FILE ) EMPTY-BUFFERS -1 WARNING ! KEY>FNAME ( ASK FOR FILE NAME ) (OPEN) 0 F.PTR ! IN @ >R 0 IN ! 1 ?TLOAD ! NEXT.BLK ( FETCH BLOCK ) INTERPRET R> IN ! CR ." END TEXT COMPILATION" CR FCB 1+ 35 0 FILL 0 ?TLOAD ! 1 WARNING ! ; ( CREATE 'END COMPILATION'= NULL WORD--TO EXIT INTERPRET LOOP ) HEX 8081 HERE : X ?TLOAD @ IF ( WE ARE 'TLOADING' ) NEXT.BLK ( GET NEXT DISK BLOCK ) 0 IN ! ELSE ( NORMAL ) BLK @ IF 1 BLK +! 0 IN ! BLK @ 3 AND 0= IF ?EXEC R> DROP THEN ELSE R> DROP THEN THEN ; ! ( RE-WRITE NAME FIELD ) IMMEDIATE ( **** 4THCOMP -- CP/M WORDSTAR TEXT COMPILATION PACKAGE ********* ) : -ABORT- ( NEW ABORT ) 0 ?TLOAD ! CR ." ABORTING COMPILE " 1 WARNING ! ERROR ; ' -ABORT- 2 - ' (ABORT) ! ( RE-WRITE VECTOR ) ( RE-WRITE OLD WORD ) HEX ' WORD CONSTANT OLDWORD ' SP.WORD 2 - CONSTANT NEWWORD : XX NEWWORD OLDWORD ! 04F1 OLDWORD 2+ ! ; XX FORGET OLDWORD DECIMAL ;S ( **** 4THCOMP -- CP/M WORDSTAR TEXT COMPILATION PACKAGE ********* ) ( UPDATED: 12/16/83 BY NAA ) 00 VARIABLE F.PTR ( FILE PTR ) 00 VARIABLE ?TLOAD : SP.WORD ( SPECIAL 'WORD' ) ?TLOAD @ 0= IF ( WE ARE NOT 'TLOADING' ) BLK @ IF ( BLOCK IS NOT ZERO ) BLK @ BLOCK ELSE ( BLOCK IS ZERO ) TIB @ THEN ELSE ( WE ARE 'TLOADING, USE ) COMPILE.RAM THEN IN @ + SWAP ENCLOSE HERE 34 32 FILL IN +! OVER - >R R HERE C! + HERE 1+ R> CMOVE ; : WARN ( ISSUE WARNING ) HERE COUNT TYPE CR HERE COUNT TYPE ." ? NOT DEFINED -- CONTINUING... " DROP 0 ; ( ISSUE COMPILATION MESSAGE ) 00 VARIABLE DBUG : .DEBUG HERE 1+ C@ 58 = IF CR ." COMPILING --> " COMPILE.RAM IN @ + 32 ENCLOSE DROP SWAP DROP TYPE SPACE THEN ; : SP.FIND ( SPECIAL FIND ) BL SP.WORD ( DO WORD ) DBUG @ IF .DEBUG THEN HERE CONTEXT @ @ (FIND) DUP 0= IF DROP HERE LATEST (FIND) THEN ; : SP.NTo Finish 4thcomp assembly compilation, 'TLOAD' the following packages: ASSEMB.PKG (Assembler) CASES.PKG (Case processor) HEXDUMP.PKG STACK.PKG NUMBER.PKG CPM.PKG UMBER ( SPECIAL NUMBER PROCESS ) 0 0 ROT DUP 1+ C@ 45 = DUP >R + (NUMBER) SWAP DROP C@ 32 - IF WARN ( ISSUE WARNING ) THEN R> IF MINUS THEN ; ( **** 4THCOMP -- CP/M WORDSTAR TEXT COMPILATION PACKAGE ********* ) ( NEW INTERPRET ) #     4 5MI CPO EC 5MI CPE F4 5MI CP FC 5MI CM CD 5MI CALL C0 1MI RNZ C8 1MI RZ D0 1MI RNC D8 1MI RC E0 1MI RPO E8 1MI RPE F0 1MI RP F8 1MI RM C9 1MI RET C3 5MI JMP C2 CONSTANT 0= D2 CONSTANT CS E2 CONSTANT PE F2 CONSTANT 0< ( **** ASSEMB -- 8080 FORTH ASSEMBLER PACKAGE ********* ) : NOT 8 + ; : MOV 8* 40 + + C, ; : MVI 8* 6 + C, C, ; : LXI 8* 1+ C, , ; : ENDIF 2 ?PAIRS HERE SWAP ! ; : IF C, HERE  0 , 2 ; : THEN [COMPILE] ENDIF ; : ELSE 2 ?PAIRS 0C3 IF ROT SWAP ENDIF 2 ; : BEGIN HERE 1 ; : UNTIL SWAP 1 ?PAIRS C, , ; : AGAIN 1 ?PAIRS 0C3 C, , ; : WHILE IF 2+ ; : REPEAT >R >R AGAIN R> R> 2 - ENDIF ; DECIMAL FORTH DEFINITIONS ;S WAP 1 ?PAIRS C, , ; : AGAIN 1 ?PAIRS 0C3 C, , ; : WHILE IF 2+ ; : REPEAT >R >R AGAIN R> R> 2 - ENDIF( **** ASSEMB -- 8080 FORTH ASSEMBLER PACKAGE ********* ) ( UPDATED: 12/16/83 BY NAA ) ( Fig-Forth 8080 assembler ) VOCABULARY ASSEMBLER IMMEDIATE ' ASSEMBLER CFA ' ;CODE 8 + ! ( PATCH ";CODE" IN NUCLEUS) : CODE ?EXEC CREATE [COMPILE] ASSEMBLER !CSP ; IMMEDIATE : C; CURRENT @ CONTEXT ! ?EXEC ?CSP SMUDGE ; IMMEDIATE : LABEL ( CREATE AN ASSEMBLER LABEL ) ?EXEC 0 VARIABLE SMUDGE -2 ALLOT [COMPILE] ASSEMBLER !CSP ; IMMEDIATE : 8* DUP + DUP + DUP + ; ASSEMBLER DEFINITIONS ( ESTABLISH REGISTER CONSTANTS ) 4 CONSTANT H 5 CONSTANT L 7 CONSTANT A 6 CONSTANT PSW 2 CONSTANT D 3 CONSTANT E 0 CONSTANT B 1 CONSTANT C 6 CONSTANT M 6 CONSTANT SP : 1MI C@ C, ; : 2MI C@ + C, ; : 3MI C@ SWAP 8* + C, ; : 4MI C@ C, C, ; : 5MI C@ C, , ; ( Fig-Forth 8080 assembler ) HEX ( **** CPM -- FORTH TO CP/M INTERFACE PACKAGE ************** ) ( UPDATED: 12/16/83 BY NAA ) ( ********* CP/M INTERFACE AND DIRECTORY STRUCTURE ******** ) HEX 0005 CONSTANT BDOS ( DOS ENTRY POINT ) 000F CONSTANT OPENFC ( OPEN FILE CONSTANT 00 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 F9 1MI SPHL E3 1MI XTHL EB 1MI XCHG 27 1MI DAA 2F 1MI CMA 37 1MI STC 3F 1MI CMC 80 2MI ADD 88  ) 0016 CONSTANT MAKEFC ( MAKE FILE CONSTANT ) 0014 CONSTANT READFC ( READ FILE CONSTANT ) 005C CONSTANT FCB ( FILE CONTROL BLOCK ) 0080 CONSTANT BUFF ( INPUT BUFFER ADDRESS ) DECIMAL FCB 0 + CONSTANT FCBDN ( DISK NAME ) FC2MI ADC 90 2MI SUB 98 2MI SBB A0 2MI ANA A8 2MI XRA B0 2MI ORA B8 2MI CMP 09 3MI DAD C1 3MI POP C5 3MI PUSH 02 3MI STAX 0A 3MI LDAX 04 3MI INR 05 3MI DCR 03 3MI INX 0B 3MI DCX C7 3MI RST D3 4MIB 1 + CONSTANT FCBFN ( FILE NAME ) FCB 9 + CONSTANT FCBFT ( FILE TYPE, 3 LETTERS ) FCB 12 + CONSTANT FCBRL ( FILES CURRENT REEL NUMBER ) FCB 15 + CONSTANT FCBRC ( FILE' RECORD COUNT 0-128 ) FCB 32 + CONSTANT C.REC ( CURRENT RECORD 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 2A 5MI LHLD 32 5MI STA 3A 5MI LDA C4 5MI CNZ CC 5MI CZ D4 5MI CNC DC 5MI CC E ) FCB 33 + CONSTANT R.REC ( RANDOM REC # ) ( CP/M BDOS COMMANDS IN 8080 CODE ) LABEL BDOSCMD ( MAKE A CP/M FILE IN DIRECTORY ) FCB D LXI ( FILE CONTROL BLOCK IN DE ) BDOS CALL ( CALL CP/M ) 0 D MVI A E MOV $     B POP D PUSH ( ERROR CODE TO STACK ) NEXT JMP ( BACK TO FORTH ) C; CODE *MAKE ( MAKE THE FILE ) B PUSH ( SAVE INTERPRETIVE POINTER ) MAKEFC C MVI BDOSCMD JMP C; : DRA ( SET DRIVE A ) 1 FCB C! ; : DRB ( SYTES-1 ) EMPTY-BUFFERS CT ! ( COUNT IN CT ) FROM.D ! ( FROM PTR IN FROM.D VARIABLE ) FROM.D @ 0 128 U/ SWAP DROP R.REC ! 8IN ( READ INTO USE ) DBUFF1 FROM.D @ 0 128 U/ DROP + COMPILE.RAM CT @ CMOVE ; ( SFIRST, SNEXT -- SEET DRIVE B ) 2 FCB C! ; ( **** CPM -- FORTH TO CP/M INTERFACE PACKAGE ************** ) : >FNAME ( HERE TO FILE NAME ) FCBFN 11 32 FILL ( BLANK OLD NAME ) HERE 1+ FCBFN HERE C@ 8 MIN CMOVE ( WRITE NEW NAME ) ; : >EXT ( HARCH DIRECTORY FUNCTIONS ) CODE *SFIRST B PUSH ( SAVE INT PTR ) HEX 11 C MVI ( FUNCTION CODE ) BDOSCMD JMP ( DO BDOS COMMAND ) C; CODE *SNEXT B PUSH ( SAVE INT PTR ) HEX 12 C MVI ( FUNCTION CODE ) ERE TO EXTENSION ) FCBFN 8 + 3 32 FILL ( BLANK OLD EXTENSION ) HERE 1+ FCBFN 8 + HERE C@ 3 MIN CMOVE ( WRITE EXT ) ; : KEY>FNAME ( INPUT FNAME FROM KEYBOARD ) CR ." ENTER 'FILENAME.EXT' --> " QUERY TIB @ 1+ C@ 58 = IF ( : ) 2 IN +! BDOSCMD JMP ( DO BDOS COMMAND ) C; DECIMAL ( DIR -- PRINT DIRECTORY ) 00 VARIABLE SCRATCH 00 VARIABLE COL.CTR ( COLUMN COUNTER ) : FNAME>? ( SET FILE NAME AMBIGUOUS ) FCBFN 11 63 FILL ( FILE NAME TO ? ) ; : .DR:  TIB @ C@ 66 - IF DRA ELSE DRB THEN THEN 46 ( . ) WORD HERE 1+ C@ 0= IF QUIT ( NULL ENTRY ) THEN >FNAME BL WORD HERE 1+ C@ IF >EXT THEN ; : MAKE ( MAKE A FILE FROM THE CURRENT FCB ) *MAKE ( MACHINE CODE ) ( PRINT DRIVE AND COLEN ) FCB C@ 64 + EMIT ." : " ; : .NAME ( PRINT THE NAME OF THE FILE ) BUFF 1+ SCRATCH @ 32 * + DUP 8 TYPE SPACE 8 + 3 TYPE 1 COL.CTR +! COL.CTR @ 4 = IF CR .DR: 0 COL.CTR ! ELSE ." : " THEN ; ( ****  255 = IF ( PRINT ) CR ." NOT ENOUGH ROOM IN DIRECTORY" QUIT THEN ; : CREATE ( ASK FOR THE FILE AND CREATE IT ) KEY>FNAME MAKE ; : .NOFILE ( PRINT NO FILE ERROR MESSAGE ) CR ." CANNOT FIND FILE " CPM -- FORTH TO CP/M INTERFACE PACKAGE ************** ) : DIR ( SCAN DIRECTORY ) CR FNAME>? ( SET FNAME TO ? ) 0 COL.CTR ! .DR: *SFIRST ( START SCAN ) 255 - IF 0 SCRATCH ! .NAME ( FIRST ENTRY ) BEGIN *SNFCBFN 8 TYPE ." ." FCBFN 8 + 3 TYPE QUIT ; CODE *ERA ( ERASE A CP/M FILE IN DIRECTORY ) B PUSH ( SAVE INTERPRETIVE POINTER ) 19 C MVI BDOSCMD JMP C; : (ERA) ( ERASE THE FILE IN FCB ) *ERA ( MACHINE LANEXT DUP SCRATCH ! 255 - WHILE .NAME ( PRINT NAME ) REPEAT CR THEN FCBFN 11 32 FILL ; ( *SWRITE -- SEQUENTIAL WRITE ) CODE *SWRITE B PUSH ( SAVE INTERPRETIVE POINTER ) HEX 15 C MVGUAGE ) 255 = IF .NOFILE THEN ; : ERA ( ASK FOR FILE AND DELETE ) KEY>FNAME (ERA) ; ( **** CPM -- FORTH TO CP/M INTERFACE PACKAGE ************** ) CODE *OPEN ( OPEN A FILE ) B PUSH ( SAVE POINTER ) 15 I BDOSCMD JMP C; DECIMAL : OPEN/MAKE ( OPEN OR MAKE A FILE IN FNAME ) *OPEN 255 = IF MAKE THEN 0 C.REC C! ; : WRITED *SWRITE IF ." DISC WRITE ERROR" QUIT THEN ; ;S  C MVI BDOSCMD JMP C; CODE *CLOSE ( CLOSE A FILE ) B PUSH ( SAVE POINTER ) 16 C MVI BDOSCMD JMP C; : (OPEN) ( OPEN THE FILE IN FNAME ) FCB 12 + 24 0 FILL *OPEN 255 = IF .NOFILE THEN ; : CLO( **** DEBUG -- FORTH DEBUG VOCABULARY PACKAGE ************* ) ( UPDATED: 12/16/83 BY NAA ) VOCABULARY DEBUG-VOC IMMEDIATE DEBUG-VOC DEFINITIONS ( hides internal Debug words) ( Prints word type: Colon, Variable, Constant, etc.) : PSE ( CLOSE THE FILE IN FNAME ) *CLOSE 255 = IF .NOFILE THEN ; : OPEN ( OPEN THE FILENAME ) KEY>FNAME (OPEN) 0 C.REC C! ; CODE *SETDMA ( SET THE DMA ADDRESS ) D POP ( TAKE STACK ENTRY ) B PUSH ( SAVE IN:WORD:TYPE SPACE DUP PFA CFA @ ( NFA --> NFA ) DO-CASES DUP PFA CFA 2 + CASE 77 ( Machine code) ECASE ' PAD CFA @ CASE BL ( colon word) ECASE ' DP CFA @ CASE 85 ( User variable) ECASE TERPRETIVE POINTER ) HEX 1A C MVI DECIMAL BDOS CALL B POP NEXT JMP C; CODE *RREAD ( RANDOM READ ) B PUSH ( INTERPRETIVE POINTER ) HEX 21 C MVI DECIMAL ( READ CODE ) BDOSCMD JMP C; : RREAD ( READ RANDOM  ' 1 CFA @ CASE 67 ( Constant) ECASE ' PREV CFA @ CASE 86 ( Variable) ECASE ' FORTH CFA @ CASE 68 ( DOES> word ) ECASE OTHERWISE 63 ( ? unkown word) END-CASES EMIT ( oRECORD ON STACK TO DMA ) 0 R.REC 2 + C! R.REC ! *RREAD 25 ?ERROR ; ( SEQUENTIAL FILE READ -- *SREAD ) 00 VARIABLE PTR 29178 CONSTANT DBUFF1 30206 CONSTANT DBUFF2 CODE *SREAD ( SEQUENTIAL READ ) utput character) 2 SPACES ; ( Print SMUDGE and PRECEEDENCE bits ) ( NFA --> NFA ) : SMUD/PREC CR SPACE DUP C@ DUP 32 AND IF 83 ( S ) ( smudge bit set) ELSE BL ENDIF EMIT SPACE  B PUSH ( INTERPRETIVE POINTER ) HEX 14 C MVI DECIMAL ( READ CODE ) BDOSCMD JMP C; ( **** CPM -- FORTH TO CP/M INTERFACE PACKAGE ************** ) : 8IN ( READ IN 8 BLOCKS RANDOMLY, TO USE ) 0 PTR ! 8 0 DO DBUFF1  64 AND IF 80 ( P ) ( preceedence bit set) ELSE BL ENDIF EMIT SPACE ; FORTH DEFINITIONS ( Prints current vocabulary words: flags - type - CFA name ) : NVLIST CONTEXT @ @ CR DEBUG PTR @ + *SETDMA ( SET ADDRESS ) *RREAD 1 R.REC +! IF LEAVE THEN 128 PTR +! LOOP BUFF *SETDMA ; ( VM>RAM -- ) 00 VARIABLE FROM.D 00 VARIABLE CT : COMPILE.RAM DBUFF2 ; : VM>RAM ( FROM DISK-2,TO USE BUFFER, <=900 B-VOC ( --> ) BEGIN SMUD/PREC P:WORD:TYPE DUP PFA 4HEX DUP ID. PFA LFA @ DUP ( next word address) 0= ( end of dict) ?PAUSE ( operator stop?) OR UNTIL DROP CR CR ; FORTH ;S %     40H ; USER VARIABLES SPACE RTS EQU 0A0H ; RETURN STACK & TERM BUFF SPACE ; CO EQU KBBUF+4 ; DISK BUFFER + 2 HEADER + 2 TAIL NBUF EQU NSCR*400H/KBBUF ; NUMBER OF BUFFERS BUF1 EQU EM-CO*NBUF ; ADDR FIRST DISK BUFFER INITR0 EQU BUF1-US ; (R0) INITS0 EQU INITR0-RTS ; (S0) ; PAGE ; ;------------------------------------------------------- ; ORG 0H ORIG: NOP JMP CLD ; VECTOR TO COLD START ; NOP JMP WRM ; VECTOR TO WARM START ; DB FIGREL ; FIG RELEASE # DB FIGREV ; FIG REVISION # DB TITLE '8080 FIG-FORTH 4THCOMP BASE CODE (09/18/84)' ;**************************************************************** ; ; ; 8080 FIG-FORTH 4THCOMP ; ; ; ; CONCEIVED BY NICK AVDONIN 09/18/84 ; ; UPDATED: 09/18/84 ;  USRVER ; USER VERSION # DB 0EH ; IMPLEMENTATION ATTRIBUTES DW TASK-7 ; TOPMOST WORD IN FORTH VOCABULARY DW BSIN ; BKSPACE CHARACTER DW INITR0 ; INIT (UP) ;<<<<<< FOLLOWING USED BY COLD; ; MUST BE IN SAME ORDER AS USER VARIABLES DW INITS0 ; IN; ; ; BASE NUCLEUS RELOCATABLE MODULE ; ; ; ;**************************************************************** ; ; RELEASE & VERSION NUMBERS ; FIGREL EQU 4 ; FIG RELEASE # FIGREV EQU 1 ; FIG REVISION # USRVER EQU 0 ; USER VERSIIT (S0) DW INITR0 ; INIT (R0) DW INITS0 ; INIT (TIB) DW 20H ; INIT (WIDTH) DW 1 ; INIT (WARNING) DW INITDP ; INIT (FENCE) DW INITDP ; INIT (DP) DW FORTH+6 ; INIT (VOC-LINK) ;<<<<<< END DATA USED BY COLD DW 5H,0B320H ; CPU NAME ( HW,LWON # ; ; ALL PUBLICATIONS OF THE FORTH INTEREST GROUP ; ARE PUBLIC DOMAIN. THEY MAY BE FURTHER ; DISTRIBUTED BY THE INCLUSION OF THIS CREDIT ; NOTICE: ; ; THIS PUBLICATION HAS BEEN MADE AVAILABLE BY THE ; FORTH INTEREST GROUP ;  ) ; ( 32 BIT, BASE 36 INTEGER ) ; ; ; +---------------+ ; B +ORIGIN | . . .W:I.E.B.A| IMPLEMENTATION ; +---------------+ ATTRIBUTES ; ^ ^ ^ ^ ^ ; | | | | +-- PROCESSOR ADDR = ; | | | | { 0 BYTE | 1 WORD } P. O. BOX 1105 ; SAN CARLOS, CA 94070 ; ; MODIFICATIONS BY NICK AVDONIN ; 1. REMOVED DISK I/O, BLOCK STRUCTURE ; ADDED FORTH COMP, CP/M STRUCTURE. ; FORTH COMP, COPYRIGHT 1984 BY NICK AVDONIN ; 2. INITIALIZE WARNING TO 1 -- DISK AVAI; | | | +---- HIGH BYTE AT ; | | | { 0 LOW ADDR | ; | | | 1 HIGH ADDR } ; | | +------ ADDR MUST BE EVEN ; | | { 0 YES | 1 NO } ; | +-------- INTERPRETER IS ; | { 0 PRE | LABLE ; 3. 'COLD' SHOULD NOT EMPTY-BUFFERS ; 4. INPUT DELETE CHANGED TO BACKSPACE -- 08H PAGE ; GLOBAL SYMBOLS DEFINED GLOBAL AT,ANDD,ALLOT GLOBAL BASE,BLK,BUILD,BRAN,BLANK,BL GLOBAL CAT,CSLL,COMP,CURR,COMMA,CFA,CSTOR,CMOVE,CR,CO1 POST } ; | INCREMENTING ; +---------- { 0 ABOVE SUFFICIENT ; | 1 OTHER DIFFER- ; ENCES EXIST } ; PAGE ; ;------------------------------------------------------ ; ; FORTH REGISTERS ; ; FORTH 8080 FORTH PUNT,CONT GLOBAL DIGIT,DEC,DOES,DODOE,DMINU,DPLUS,DPL,DOVAR GLOBAL DOCON,DP0,DDUP,DP,DTRAI,DPUSH,DOCOL,DROP,DUP GLOBAL ENCL,EQUAL,EXEC GLOBAL FROMR,FILL,FENCE GLOBAL GREAT GLOBAL HERE,HLD,HOLD,HPUSH GLOBAL INN,IDO GLOBAL LIT,LBRAC,LFA,LEAVE,RESERVATION RULES ; ----- ---- ------------------------ ; IP BC SHOULD BE PRESERVED ACROSS ; FORTH WORDS ; W DE SOMETIMES OUTPUT FROM NEXT ; MAY BE ALTERED BEFORE JMP'ING TO NEXT ; INPUT ONLY WHEN 'DPUSH' CALLED ; SP SP SHOULD BE USED ONLY ALESS,LATES GLOBAL MINUS GLOBAL NEXT,NFA,NOOP GLOBAL ORIG,ORR,OUTT,OVER,ONE,ONEP GLOBAL PLUS,PAD,PFA,PSTOR,PDOTQ,PFIND GLOBAL QERR,QUERY,QCOMP,QPAIR,QTERM GLOBAL RR,ROT,RPP,RPSTO GLOBAL SWAP,SZERO,SPSTO,SPAT,STATE,SEMIS,STORE,SUBB,SEMIS,SPACE S DATA STACK ; ACROSS FORTH WORDS ; MAY BE USED WITHIN FORTH WORDS ; IF RESTORED BEFORE 'NEXT' ; HL NEVER OUTPUT FROM NEXT ; INPUT ONLY WHEN 'HPUSH' CALLED ; UP: DW INITR0 ; USER AREA POINTER RPP: DW INITR0 ; RETURN STACK POINTER ; ; GLOBAL TIB,TWO,TWOP,THREE,TDUP,TOR,TOGGL,TYPE GLOBAL USTAR,UP,ULESS,USLAS GLOBAL VOCL GLOBAL WARN,WIDTH GLOBAL XDO,XPLOO,XORR,XLOOP GLOBAL ZEQU,ZLESS,ZBRAN,ZERO ; EXTERNAL SYMBOLS DEFINED EXTRN CLD ; COLD START EXTRN WRM ; WARM START ------------------------------------------------------ ; ; COMMENT CONVENTIONS: ; ; = MEANS "IS EQUAL TO" ; <- MEANS ASSIGNMENT ; ; NAME = ADDRESS OF NAME ; (NAME) = CONTENTS AT NAME ; ((NAME))= INDIRECT CONTENTS ; ; CFA = ADDRESS OF CODE FIELD  EXTRN TASK ; TOP MOST WORD IN FORTH VOC EXTRN INITDP ; INITIAL DICTIONARY POINTER EXTRN FORTH ; INITIAL VOCABULARY LINK EXTRN PEMIT ; PRINTER EMIT EXTRN PKEY ; KEYBOARD EXTRN PQTER EXTRN PCR EXTRN CREAT ; CREATE EXTRN ERROR ; ERROR PROCESS ; LFA = ADDRESS OF LINK FIELD ; NFA = ADDR OF START OF NAME FIELD ; PFA = ADDR OF START OF PARAMETER FIELD ; ; S1 = ADDR OF 1ST WORD OF PARAMETER STACK ; S2 = ADDR OF 2ND WORD OF PARAMETER STACK ; R1 = ADDR OF 1ST WORD OF RETURN STACK ; R2 = ADDR OING EXTRN WORD EXTRN QTLOAD EXTRN NXTBLK PAGE ; ASCII CHARACTERS USED ; ABL EQU 20H ; SPACE ACR EQU 0DH ; CARRIAGE RETURN ADOT EQU 02EH ; PERIOD BELL EQU 07H ; (^G) BSIN EQU 08H ; INPUT BACKSPACE CHR = (^H)--MOD NAA BSOUT EQU 08H ; OUTPUTF 2ND WORD OF RETURN STACK ; ( ABOVE STACK POSITIONS VALID BEFORE & AFTER EXECUTION ; OF ANY WORD, NOT DURING. ) ; ; LSB = LEAST SIGNIFICANT BIT ; MSB = MOST SIGNIFICANT BIT ; LB = LOW BYTE ; HB = HIGH BYTE ; LW = LOW WORD ; HW = HIGH WORD ; ( MA BACKSPACE (^H) DLE EQU 10H ; (^P) LF EQU 0AH ; LINE FEED FF EQU 0CH ; FORM FEED (^L) ; ; MEMORY ALLOCATION ; EM EQU 7A00H ; TOP OF MEMORY + 1 = LIMIT NSCR EQU 2 ; NUMBER OF 1024 BYTE SCREENS KBBUF EQU 1024 ; DATA BYTES PER DISK BUFFER US EQU Y BE USED AS SUFFIX TO ABOVE NAMES ) ; PAGE ;-------------------------------------------------- ; ; NEXT, THE FORTH ADDRESS INTERPRETER ; ( POST INCREMENTING VERSION ) ; ; ; DPUSH: PUSH D HPUSH: PUSH H NEXT: CNEXT: LDAX B ;(W) <- ((IP)) I&     NX B ;(IP) <- (IP)+2 MOV L,A LDAX B INX B MOV H,A ; (HL) <- CFA NEXT1: MOV E,M ;(PC) <- ((W)) INX H MOV D,M XCHG PCHL ; NOTE: (DE) = CFA+1 PAGE ; FORTH DICTIONARY ; ; ; DICTIONARY FORMAT: ; ; BYTE ; ADDRESS NAME CONTENTSE ; DB 86H ; (FIND) (2-1)FAILURE DB '(FIND' ; (2-3)SUCCESS DB ')'+80H DW DIGIT-8 PFIND: DW $+2 POP D ; (DE) <- NFA PFIN1: POP H ; (HL) <- STRING ADDR PUSH H ; SAVE STRING ADDR FOR NEXT ITERATION LDAX D XRA M ; CHECK LENGTHS & SMUDGE BIT ; ------- ---- -------- ; ( MSB=1 ; ( P=PRECEDENCE BIT ; ( S=SMUDGE BIT ; NFA NAME FIELD 1PS < NAME LENGTH ; 0<1CHAR> MSB=0, NAME'S 1ST CHAR ; 0<2CHAR> ; ... ; 1 MSB=1, NAME'S LAST CHR ; LFA LINK F ANI 3FH JNZ PFIN4 ; LENGTHS DIFFERENT ; ; LENGTHS MATCH, CHECK EACH CHR PFIN2: INX H ; (HL) <- ADDR NEXT CHR IN STRING INX D ; (DE) <- ADDR NEXT CHR IN NF LDAX D XRA M ; IGNORE MSB ADD A JNZ PFIN3 ; NO MATCH JNC PFIN2 ; MATCH SO FAR, LIELD = PREVIOUS WORD'S NFA ; ;LABEL: CFA CODE FIELD = ADDR CPU CODE ; ; PFA PARAMETER <1PARAM> 1ST PARAMETER BYTE ; FIELD <2PARAM> ; ... ; ; DP0: DB 83H ; LIT DB 'LI' DB 'T'+80H DW 0 ; ZEROOOP AGAIN LXI H,5 ; STRING MATCHES DAD D ; ((SP)) <- PFA XTHL ; ; BACK UP TO LENGTH BYTE OF NF = NFA PFIN6: DCX D LDAX D ORA A JP PFIN6 ; IF MSB = 1 THEN (DE) = NFA MOV E,A ; (DE) <- LENGTH BYTE MVI D,0 LXI H,1 ; (HL) <- TRUE JMP DP LINK LIT: DW $+2 ;(S1) <- ((IP)) LDAX B ; (HL) <- ((IP)) = LITERAL INX B ; (IP) <- (IP) + 2 MOV L,A ; LB LDAX B ; HB INX B MOV H,A JMP HPUSH ; (S1) <- (HL) ; DB 87H ; EXECUTE DB 'EXECUT' DB 'E'+80H DW LIT-6 EXEC: DW $+2 POP H ;USH ; RETURN, NF FOUND ; ABOVE NF NOT A MATCH, TRY ANOTHER PFIN3: JC PFIN5 ; IF NOT END OF NF PFIN4: INX D ; THEN FIND END OF NF LDAX D ORA A JP PFIN4 PFIN5: INX D ; (DE) <- LFA XCHG MOV E,M ; (DE) <- (LFA) INX H MOV D,M MOV A,D ORA  (HL) <- (S1) = CFA JMP NEXT1 ; DB 86H ; BRANCH DB 'BRANC' DB 'H'+80H DW EXEC-0AH BRAN: DW $+2 ;(IP) <- (IP) + ((IP)) BRAN1: MOV H,B ; (HL) <- (IP) MOV L,C MOV E,M ; (DE) <- ((IP)) = BRANCH OFFSET INX H MOV D,M DCX H DAD D ; (HL) <E ; IF (LFA) <> 0 JNZ PFIN1 ; THEN TRY PREVIOUS DICT. DEF. ; ; ELSE END OF DICTIONARY POP H ; DISCARD STRING ADDR LXI H,0 ; (HL) <- FALSE JMP HPUSH ; RETURN, NO MATCH FOUND PAGE ; *************** ; * ENCLOSE * ; *************** ;- (HL) + ((IP)) MOV C,L ; (IP) <- (HL) MOV B,H JMP NEXT ; DB 87H ; 0BRANCH DB '0BRANC' DB 'H'+80H DW BRAN-9 ZBRAN: DW $+2 POP H MOV A,L ORA H JZ BRAN1 ; IF (S1)=0 THEN BRANCH INX B ; ELSE SKIP BRANCH OFFSET INX B JMP NEXT ;  ; MODIFIED FROM THE 'FIG' VERSION TO ALLOW ; SEARCHES UP TO 65535 BYTES. ; (PREVIOUSLY ON 8-BITS; 256 BYTES) ; DB 87H ; ENCLOSE DB 'ENCLOS' DB 'E'+80H DW PFIND-9 ENCL: DW $+2 POP D ; (DE) <- (S1) = DELIMITER CHAR POP H ; (HL) <- (S2) = AD DB 86H ; (LOOP) DB '(LOOP' DB ')'+80H DW ZBRAN-0AH XLOOP: DW $+2 LXI D,1 ; (DE) <- INCREMENT XLOO1: LHLD RPP ; ((HL)) = INDEX MOV A,M ; INDEX <- INDEX + INCR ADD E MOV M,A MOV E,A INX H MOV A,M ADC D MOV M,A INX H ; ((HL)) = LIDR TEXT TO SCAN PUSH H ; (S4) <- ADDR MOV A,E LXI D,-1 ; INITIALIZE CHR OFFSET COUNTER DCX H ; (HL) <- ADDR-1 ; ; SKIP OVER LEADING DELIMITER CHRS ENCL1: INX H INX D CMP M ; IF TEXT CHR = DELIM CHR JZ ENCL1 ; THEN LOOP AGAIN ; ; ELSE NMIT INR D DCR D MOV D,A ; (DE) <- NEW INDEX JM XLOO2 ; IF INCR > 0 MOV A,E SUB M ; THEN (A) <- INDEX - LIMIT MOV A,D INX H SBB M JMP XLOO3 XLOO2: MOV A,M ; ELSE (A) <- LIMIT - INDEX SUB E INX H MOV A,M SBB D ; ; IF (A) < 0 ON-DELIM CHR FOUND ; PUSH D ; OFFSET TO 1ST NON-DELIMITER CHAR PUSH B ; SAVE 'IP' MOV B,A ; (B) <- DELIM CHR MOV A,M ; IF 1ST NON-DELIM = NULL ANA A JNZ ENCL2 ; FOUND NULL (00), STOP THE SEARCH ; INX D ; CHARACTER FOLLOWING NULL POP B XLOO3: JM BRAN1 ; THEN LOOP AGAIN INX H ; ELSE DONE SHLD RPP ; DISCARD R1 & R2 INX B ; SKIP BRANCH OFFSET INX B JMP NEXT ; DB 87H ; (+LOOP) DB '(+LOOP' DB ')'+80H DW XLOOP-9 XPLOO: DW $+2 POP D ; (DE) <- INCR JMP XLOO1 ; DB 84H ;; GET BACK 'IP' PUSH D DCX D ; (S1) <- OFFSET TO NULL PUSH D JMP NEXT ; ELSE TEXT CONTAINS NON-DELIM & NON-NULL CHR ; ENCL2: MOV A,B ; (A) <- DELIM CHR INX H ; (HL) <- ADDR NEXT CHR INX D ; (DE) <- OFFSET TO NEXT CHR CMP M ; IF NEXT CHR  (DO) DB '(DO' DB ')'+80H DW XPLOO-0AH XDO: DW $+2 LHLD RPP ; (RP) <- (RP) - 4 DCX H DCX H DCX H DCX H SHLD RPP POP D ; (R1) <- (S1) = INIT INDEX MOV M,E INX H MOV M,D POP D ; (R2) <- (S2) = LIMIT INX H MOV M,E INX H MO<> DELIM CHR JZ ENCL4 MOV A,M ; AND IF NEXT CHR <> NULL ANA A JNZ ENCL2 ; THEN CONTINUE SCAN ; ELSE CHARACTER = NULL (00) ; ENCL3: POP B ; GET BACK 'IP' PUSH D ; (S2) <- OFFSET TO NULL PUSH D ; (S1) <- OFFSET TO NULL JMP NEXT ; ELSE CV M,D JMP NEXT ; DB 81H ; I DB 'I'+80H DW XDO-7 IDO: DW $+2 ;(S1) <- (R1) , (R1) UNCHANGED LHLD RPP MOV E,M ; (DE) <- (R1) INX H MOV D,M PUSH D ; (S1) <- (DE) JMP NEXT ; DB 85H ; DIGIT DB 'DIGI' DB 'T'+80H DW IDO-4 DIGIT: DWHARACTER = DELIMITER CHARACTER ; ENCL4: POP B ; GET BACK 'IP' PUSH D ; (S2) <- OFFSET TO BYTE ; FOLLOWING TEXT INX D ; (S1) <- OFFSET TO 2 BYTES AFTER ; END OF WORD PUSH D JMP NEXT PAGE DB 84H ; EMIT DB 'EMI' DB 'T'+80H  $+2 POP H ; (L) <- (S1)LB = ASCII CHR TO BE ; CONVERTED POP D ; (DE) <- (S2) = BASE VALUE MOV A,E SUI 30H ; IF CHR > "0" JM DIGI2 CPI 0AH ; AND IF CHR > "9" JM DIGI1 SUI 7 CPI 0AH ; AND IF CHR >= "A" JM DIGI2 ; ; THEN VALID NUME DW ENCL-0AH EMIT: DW DOCOL DW PEMIT DW ONE,OUTT DW PSTOR,SEMIS ; DB 83H ; KEY DB 'KE' DB 'Y'+80H DW EMIT-7 KEY: DW $+2 JMP PKEY ; DB 89H ; ?TERMINAL DB '?TERMINA' DB 'L'+80H DW KEY-6 QTERM: DW $+2 LXI H,0 JMP PQTER ; DBRIC OR ALPHA CHR DIGI1: CMP L ; IF < BASE VALUE JP DIGI2 ; ; THEN VALID DIGIT CHR MOV E,A ; (S2) <- (DE) = CONVERTED DIGIT LXI H,1 ; (S1) <- TRUE JMP DPUSH ; ; ELSE INVALID DIGIT CHR DIGI2: MOV L,H ; (HL) <- FALSE JMP HPUSH ; (S1) <- FALS 82H ; CR DB 'C' DB 'R'+80H DW QTERM-0CH CR: DW DOCOL DW ZERO DW OUTT,STORE ; CLEAR CHAR COUNT DW PCR,SEMIS ; DB 85H ; CMOVE DB 'CMOV' DB 'E'+80H DW CR-5 CMOVE: DW $+2 MOV L,C ; (HL) <- (IP) MOV H,B POP B ; (BC) <- (S1) = #CHRS'      POP D ; (DE) <- (S2) = DEST ADDR XTHL ; (HL) <- (S3) = SOURCE ADDR ; ; (S1) <- (IP) JMP CMOV2 ; RETURN IF #CHRS = 0 CMOV1: MOV A,M ; ((DE)) <- ((HL)) INX H ; INC SOURCE ADDR STAX D INX D ; INC DEST ADDR DCX B ; DEC #CHRS CMOV2: MOV A,BAT-6 SPSTO: DW $+2 ;(SP) <- (S0) ( USER VARIABLE ) LHLD UP ; (HL) <- USER VAR BASE ADDR LXI D,6 DAD D ; (HL) <- S0 MOV E,M ; (DE) <- (S0) INX H MOV D,M XCHG SPHL ; (SP) <- (S0) JMP NEXT ; DB 83H ; RP@ DB 'RP' DB '@'+80H DW SPST ORA C JNZ CMOV1 ; REPEAT IF #CHRS <> 0 POP B ; RESTORE (IP) FROM (S1) JMP NEXT ; DB 82H ; U* 16X16 UNSIGNED MULTIPLY DB 'U' ; AVG EXECUTION TIME = 994 CYCLES DB '*'+80H DW CMOVE-8 USTAR: DW $+2 POP D ; (DE) <- MPLIER POP H ; (HL) <- O-6 RPAT: DW $+2 ;(S1) <- (RP) LHLD RPP JMP HPUSH ; DB 83H ; RETURN STACK POINTER STORE DB 'RP' DB '!'+80H DW RPAT-6 RPSTO: DW $+2 ;(RP) <- (R0) ( USER VARIABLE ) LHLD UP ; (HL) <- USER VARIABLE BASE ADDR LXI D,8 DAD D ; (HL) <- R0 MMPCAND PUSH B ; SAVE IP MOV B,H MOV A,L ; (BA) <- MPCAND CALL MPYX ; (AHL)1 <- MPCAND.LB * MPLIER ; 1ST PARTIAL PRODUCT PUSH H ; SAVE (HL)1 MOV H,A MOV A,B MOV B,H ; SAVE (A)1 CALL MPYX ; (AHL)2 <- MPCAND.HB * MPLIER ; OV E,M ; (DE) <- (R0) INX H MOV D,M XCHG SHLD RPP ; (RP) <- (R0) JMP NEXT ; DB 82H ; ;S DB ';' DB 'S'+80H DW RPSTO-6 SEMIS: DW $+2 ;(IP) <- (R1) LHLD RPP MOV C,M ; (BC) <- (R1) INX H MOV B,M INX H SHLD RPP ; (RP) <- (RP) + 2 2ND PARTIAL PRODUCT POP D ; (DE) <- (HL)1 MOV C,D ; (BC) <- (AH)1 ; FORM SUM OF PARTIALS: ; (AHL) 1 ; + (AHL) 2 ; -------- ; (AHLE) DAD B ; (HL) <- (HL)2 + (AH)1 ACI 0 ; (AHLE) <- (BA) * (DE) MOV D,L MOV L,H MOV H,A ; (HLD JMP NEXT ; DB 85H ; LEAVE DB 'LEAV' DB 'E'+80H DW SEMIS-5 LEAVE: DW $+2 ;LIMIT <- INDEX LHLD RPP MOV E,M ; (DE) <- (R1) = INDEX INX H MOV D,M INX H MOV M,E ; (R2) <- (DE) = LIMIT INX H MOV M,D JMP NEXT ; DB 82H ; >R DB 'E) <- MPLIER * MPCAND POP B ; RESTORE IP PUSH D ; (S2) <- PRODUCT.LW JMP HPUSH ; (S1) <- PRODUCT.HW ; ; MULTIPLY PRIMITIVE ; (AHL) <- (A) * (DE) ; #BITS = 24 8 16 MPYX: LXI H,0 ; (HL) <- 0 = PARTIAL PRODUCT.LW MVI C,8 ; LOOP COUNTER MPYX1>' DB 'R'+80H DW LEAVE-8 TOR: DW $+2 ;(R1) <- (S1) POP D ; (DE) <- (S1) LHLD RPP DCX H ; (RP) <- (RP) - 2 DCX H SHLD RPP MOV M,E ; ((HL)) <- (DE) INX H MOV M,D JMP NEXT ; DB 82H ; R> DB 'R' DB '>'+80H DW TOR-5 FROMR: DW $+2: DAD H ; LEFT SHIFT (AHL) 24 BITS RAL JNC MPYX2 ; IF NEXT MPLIER BIT = 1 DAD D ; THEN ADD MPCAND ACI 0 MPYX2: DCR C ; IF NOT LAST MPLIER BIT JNZ MPYX1 ; THEN LOOP AGAIN RET ; ELSE DONE ; DB 82H ; U/ DB 'U' DB '/'+80H DW USTAR-5 USL ;(S1) <- (R1) LHLD RPP MOV E,M ; (DE) <- (R1) INX H MOV D,M INX H SHLD RPP ; (RP) <- (RP) + 2 PUSH D ; (S1) <- (DE) JMP NEXT ; DB 81H ; R DB 'R'+80H DW FROMR-5 RR: DW IDO+2 ; DB 82H ; 0= DB '0' DB '='+80H DW RR-4 ZEQU: DWAS: DW $+2 LXI H,4 DAD SP ; ((HL)) <- NUMERATOR.LW MOV E,M ; (DE) <- NUMER.LW MOV M,C ; SAVE IP ON STACK INX H MOV D,M MOV M,B POP B ; (BC) <- DENOMINATOR POP H ; (HL) <- NUMER.HW MOV A,L SUB C ; IF NUMER >= DENOM MOV A,H SBB B  $+2 POP H ; (HL) <- (S1) MOV A,L ORA H ; IF (HL) = 0 LXI H,0 ; THEN (HL) <- FALSE JNZ ZEQU1 INX H ; ELSE (HL) <- TRUE ZEQU1: JMP HPUSH ; (S1) <- (HL) ; DB 82H ; 0< DB '0' DB '<'+80H DW ZEQU-5 ZLESS: DW $+2 POP H ; (HL) <- (S1) DJC USLA1 LXI H,0FFFFH ; THEN OVERFLOW LXI D,0FFFFH ; SET REM & QUOT TO MAX JMP USLA7 USLA1: MVI A,16 ; LOOP COUNTER USLA2: DAD H ; LEFT SHIFT (HLDE) THRU CARRY RAL XCHG DAD H JNC USLA3 INX D ANA A USLA3: XCHG ; SHIFT DONE RAR ; RESAD H ; IF (HL) >= 0 LXI H,0 ; THEN (HL) <- FALSE JNC ZLES1 INX H ; ELSE (HL) <- TRUE ZLES1: JMP HPUSH ; (S1) <- (HL) ; DB 81H ; + DB '+'+80H DW ZLESS-5 PLUS: DW $+2 ;(S1) <- (S1) + (S2) POP D POP H DAD D JMP HPUSH ; DB 82H ; D+ (4TORE 1ST CARRY PUSH PSW ; SAVE COUNTER JNC USLA4 ; IF CARRY = 1 MOV A,L ; THEN (HL) <- (HL) - (BC) SUB C MOV L,A MOV A,H SBB B MOV H,A JMP USLA5 USLA4: MOV A,L ; ELSE TRY (HL) <- (HL) - (BC) SUB C MOV L,A MOV A,H SBB B ; (HL) <- -2) DB 'D' ; XLW XHW YLW YHW --- SLW SHW DB '+'+80H ; S4 S3 S2 S1 S2 S1 DW PLUS-4 DPLUS: DW $+2 LXI H,6 DAD SP ; ((HL)) = XLW MOV E,M ; (DE) = XLW MOV M,C ; SAVE IP ON STACK INX H MOV D,M MOV M,B POP B ; (BC) <- YHW PARTIAL REMAINDER MOV H,A JNC USLA5 DAD B ; UNDERFLOW, RESTORE DCX D USLA5: INX D ; INC QUOT USLA6: POP PSW ; RESTORE COUNTER DCR A ; IF COUNTER > 0 JNZ USLA2 ; THEN LOOP AGAIN USLA7: POP B ; ELSE DONE, RESTORE IP PUSH H ; (S2) <- REMAINDEPOP H ; (HL) <- YLW DAD D XCHG ; (DE) <- YLW + XLW = SUM.LW POP H ; (HL) <- XHW MOV A,L ADC C MOV L,A ; (HL) <- YHW + XHW + CARRY MOV A,H ADC B MOV H,A POP B ; RESTORE IP PUSH D ; (S2) <- SUM.LW JMP HPUSH ; (S1) <- SUM.HW ; DB 8R PUSH D ; (S1) <- QUOTIENT JMP NEXT ; DB 83H ; AND DB 'AN' DB 'D'+80H DW USLAS-5 ANDD: DW $+2 ; (S1) <- (S1) AND (S2) POP D POP H MOV A,E ANA L MOV L,A MOV A,D ANA H MOV H,A JMP HPUSH ; DB 82H ; OR DB 'O' DB 'R'+80H 5H ; MINUS DB 'MINU' DB 'S'+80H DW DPLUS-5 MINUS: DW $+2 ;(S1) <- -(S1) ( 2'S COMPLEMENT ) POP H MOV A,L CMA MOV L,A MOV A,H CMA MOV H,A INX H JMP HPUSH ; DB 86H ; DMINUS DB 'DMINU' DB 'S'+80H DW MINUS-8 DMINU: DW $+2 P DW ANDD-6 ORR: DW $+2 ; (S1) <- (S1) OR (S2) POP D POP H MOV A,E ORA L MOV L,A MOV A,D ORA H MOV H,A JMP HPUSH ; DB 83H ; XOR DB 'XO' DB 'R'+80H DW ORR-5 XORR: DW $+2 ; (S1) <- (S1) XOR (S2) POP D POP H MOV A,E XRA L OP H ; (HL) <- HW POP D ; (DE) <- LW SUB A SUB E ; (DE) <- 0 - (DE) MOV E,A MVI A,0 SBB D MOV D,A MVI A,0 SBB L ; (HL) <- 0 - (HL) MOV L,A MVI A,0 SBB H MOV H,A PUSH D ; (S2) <- LW JMP HPUSH ; (S1) <- HW ; DB 84H ; OVER D MOV L,A MOV A,D XRA H MOV H,A JMP HPUSH ; DB 83H ; SP@ DB 'SP' DB '@'+80H DW XORR-6 SPAT: DW $+2 ;(S1) <- (SP) LXI H,0 DAD SP ; (HL) <- (SP) JMP HPUSH ; (S1) <- (HL) ; DB 83H ; STACK POINTER STORE DB 'SP' DB '!'+80H DW SPB 'OVE' DB 'R'+80H DW DMINU-9 OVER: DW $+2 POP D POP H PUSH H JMP DPUSH ; DB 84H ; DROP DB 'DRO' DB 'P'+80H DW OVER-7 DROP: DW $+2 POP H JMP NEXT ; DB 84H ; SWAP DB 'SWA' DB 'P'+80H DW DROP-7 SWAP: DW $+2 POP H XTHL(      JMP HPUSH ; DB 83H ; DUP DB 'DU' DB 'P'+80H DW SWAP-7 DUP: DW $+2 POP H PUSH H JMP HPUSH ; DB 84H ; 2DUP DB '2DU' DB 'P'+80H DW DUP-6 TDUP: DW $+2 POP H POP D PUSH D PUSH H JMP DPUSH ; DB 82H ; PLUS STORE DB '+' DW VAR-0BH USER: DW DOCOL DW CON DW PSCOD DOUSE: INX D ; (DE) <- PFA XCHG MOV E,M ; (DE) <- USER VARIABLE OFFSET MVI D,0 LHLD UP ; (HL) <- USER VARIABLE BASE ADDR DAD D ; (HL) <- (HL) + (DE) JMP HPUSH ; (S1) <- BASE + OFFSET ; ****** DB '!'+80H DW TDUP-7 PSTOR: DW $+2 ;((S1)) <- ((S1)) + (S2) POP H ; (HL) <- (S1) = ADDR POP D ; (DE) <- (S2) = INCR MOV A,M ; ((HL)) <- ((HL)) + (DE) ADD E MOV M,A INX H MOV A,M ADC D MOV M,A JMP NEXT ; DB 86H ; TOGGLE DB 'TOG*** ; * 0 * ; ********* ; DB 81H ; 0 DB '0'+80H DW USER-7 ZERO: DW DOCON DW 0 ; ********* ; * 1 * ; ********* ; DB 81H ; 1 DB '1'+80H DW ZERO-4 ONE: DW DOCON DW 1 ; ********* ; * 2 * ; ********* ; DB 81H ;GL' DB 'E'+80H DW PSTOR-5 TOGGL: DW $+2 ;((S2)) <- ((S2)) XOR (S1)LB POP D ; (E) <- BYTE MASK POP H ; (HL) <- ADDR MOV A,M XRA E MOV M,A ; (ADDR) <- (ADDR) XOR (E) JMP NEXT ; DB 81H ; @ DB '@'+80H DW TOGGL-9 AT: DW $+2 ;(S1) <- ((S 2 DB '2'+80H DW ONE-4 TWO: DW DOCON DW 2 ; ********* ; * 3 * ; ********* ; DB 81H ; 3 DB '3'+80H DW TWO-4 THREE: DW DOCON DW 3 ; ********** ; * BL * ; ********** ; DB 82H ; BL DB 'B' DB 'L'+80H DW THREE-4 B1)) POP H ; (HL) <- ADDR MOV E,M ; (DE) <- (ADDR) INX H MOV D,M PUSH D ; (S1) <- (DE) JMP NEXT ; DB 82H ; C@ DB 'C' DB '@'+80H DW AT-4 CAT: DW $+2 ;(S1) <- ((S1))LB POP H ; (HL) <- ADDR MOV L,M ; (HL) <- (ADDR)LB MVI H,0 JMP HL: DW DOCON DW 20H ; *********** ; * C/L * ; *********** ; DB 83H ; C/L ( CHARACTERS/LINE ) DB 'C/' DB 'L'+80H DW BL-5 CSLL: DW DOCON DW 64 ; ************* ; * FIRST * ; ************* ; DB 85H ; FIRST DB 'FIRS' DBPUSH ; DB 82H ; 2@ DB '2' DB '@'+80H DW CAT-5 TAT: DW $+2 POP H ; (HL) <- ADDR HW LXI D,2 DAD D ; (HL) <- ADDR LW MOV E,M ; (DE) <- LW INX H MOV D,M PUSH D ; (S2) <- LW LXI D,-3 ; (HL) <- ADDR HW DAD D MOV E,M ; (DE) <- HW I 'T'+80H DW CSLL-6 FIRST: DW DOCON DW BUF1 ; ************* ; * LIMIT * ; ************* ; DB 85H ; LIMIT DB 'LIMI' DB 'T'+80H DW FIRST-8 LIMIT: DW DOCON DW EM ; ************* ; * B/BUF * ; ************* ; DB 85H ; BNX H MOV D,M PUSH D ; (S1) <- HW JMP NEXT ; DB 81H ; STORE DB '!'+80H DW TAT-5 STORE: DW $+2 ;((S1)) <- (S2) POP H ; (HL) <- (S1) = ADDR POP D ; (DE) <- (S2) = VALUE MOV M,E ; ((HL)) <- (DE) INX H MOV M,D JMP NEXT ; DB 82H ; C /BUF ( BYTES/BUFFER ) DB 'B/BU' DB 'F'+80H DW LIMIT-8 BBUF: DW DOCON DW KBBUF ; ************* ; * B/SCR * ; ************* ; DB 85H ; B/SCR ( BUFFERS/SCREEN ) DB 'B/SC' DB 'R'+80H DW BBUF-8 BSCR: DW DOCON DW 400H/KBBUF ;STORE DB 'C' DB '!'+80H DW STORE-4 CSTOR: DW $+2 ;((S1))LB <- (S2)LB POP H ; (HL) <- (S1) = ADDR POP D ; (DE) <- (S2) = BYTE MOV M,E ; ((HL))LB <- (E) JMP NEXT ; ********** ; * 2: * ; ********** ; DB 82H ; 2 STORE DB '2' DB *************** ; * +ORIGIN * ; *************** ; DB 87H ; +ORIGIN DB '+ORIGI' DB 'N'+80H DW BSCR-8 PORIG: DW DOCOL DW LIT DW ORIG DW PLUS DW SEMIS PAGE ; USER VARIABLES ; ; ; ********** ; * S0 * ; ********** ; DB  '!'+80H DW CSTOR-5 TSTOR: DW $+2 POP H ; (HL) <- ADDR POP D ; (DE) <- HW MOV M,E ; (ADDR) <- HW INX H MOV M,D INX H ; (HL) <- ADDR LW POP D ; (DE) <- LW MOV M,E ; (ADDR+2) <- LW INX H MOV M,D JMP NEXT ; ********* ; * : *82H ; S0 DB 'S' DB '0'+80H DW PORIG-0AH SZERO: DW DOUSE DW 6 ; ********** ; * R0 * ; ********** ; DB 82H ; R0 DB 'R' DB '0'+80H DW SZERO-5 RZERO: DW DOUSE DW 8 ; *********** ; * TIB * ; *********** ; DB 83H ; T ; ********* ; DB 0C1H ; : DB ':'+80H DW TSTOR-5 COLON: DW DOCOL DW QEXEC DW SCSP DW CURR DW AT DW CONT DW STORE DW CREAT DW RBRAC DW PSCOD DOCOL: LHLD RPP DCX H ; (R1) <- (IP) MOV M,B DCX H ; (RP) <- (RP) - 2 MOV M,C IB DB 'TI' DB 'B'+80H DW RZERO-5 TIB: DW DOUSE DB 0AH ; ************* ; * WIDTH * ; ************* ; DB 85H ; WIDTH DB 'WIDT' DB 'H'+80H DW TIB-6 WIDTH: DW DOUSE DB 0CH ; *************** ; * WARNING * ; ***********SHLD RPP INX D ; (DE) <- CFA+2 = (W) MOV C,E ; (IP) <- (DE) = (W) MOV B,D JMP NEXT ; ********* ; * ; * ; ********* ; DB 0C1H ; ; DB ';'+80H DW COLON-4 SEMI: DW DOCOL DW QCSP DW COMP DW SEMIS DW SMUDG DW LBRAC DW SEMIS**** ; DB 87H ; WARNING DB 'WARNIN' DB 'G'+80H DW WIDTH-8 WARN: DW DOUSE DB 0EH ; ************* ; * FENCE * ; ************* ; DB 85H ; FENCE DB 'FENC' DB 'E'+80H DW WARN-0AH FENCE: DW DOUSE DB 10H ; ********** ; *  ; ************ ; * NOOP * ; ************ ; DB 84H ; NOOP DB 'NOO' DB 'P'+80H DW SEMI-4 NOOP: DW $+2 NOP NOP JMP NEXT ; **************** ; * CONSTANT * ; **************** ; DB 88H ; CONSTANT DB 'CONSTAN' DB 'T'+ DP * ; ********** ; DB 82H ; DP DB 'D' DB 'P'+80H DW FENCE-8 DP: DW DOUSE DB 12H ; **************** ; * VOC-LINK * ; **************** ; DB 88H ; VOC-LINK DB 'VOC-LIN' DB 'K'+80H DW DP-5 VOCL: DW DOUSE DW 14H ; **80H DW NOOP-7 CON: DW DOCOL DW CREAT DW SMUDG DW COMMA DW PSCOD DOCON: INX D ; (DE) <- PFA XCHG MOV E,M ; (DE) <- (PFA) INX H MOV D,M PUSH D ; (S1) <- (PFA) JMP NEXT ; **************** ; * VARIABLE * ; **************** ;********* ; * BLK * ; *********** ; DB 83H ; BLK DB 'BL' DB 'K'+80H DW VOCL-0BH BLK: DW DOUSE DB 16H ; ********** ; * IN * ; ********** ; DB 82H ; IN DB 'I' DB 'N'+80H DW BLK-6 INN: DW DOUSE DB 18H ; ********** DB 88H ; VARIABLE DB 'VARIABL' DB 'E'+80H DW CON-0BH VAR: DW DOCOL DW CON DW PSCOD DOVAR: INX D ; (DE) <- PFA PUSH D ; (S1) <- PFA JMP NEXT ; ************ ; * USER * ; ************ ; DB 84H ; USER DB 'USE' DB 'R'+80H * ; * OUT * ; *********** ; DB 83H ; OUT DB 'OU' DB 'T'+80H DW INN-5 OUTT: DW DOUSE DB 1AH ; *********** ; * SCR * ; *********** ; DB 83H ; SCR DB 'SC' DB 'R'+80H DW OUTT-6 SCR: DW DOUSE DB 1CH ; **************)      ; * OFFSET * ; ************** ; DB 86H ; OFFSET DB 'OFFSE' DB 'T'+80H DW SCR-6 OFSET: DW DOUSE DB 1EH ; *************** ; * CONTEXT * ; *************** ; DB 87H ; CONTEXT DB 'CONTEX' DB 'T'+80H DW OFSET-9 CONT: DW DO DB '>'+80H DW ULESS-5 GREAT: DW DOCOL DW SWAP DW LESS DW SEMIS ; DB 83H ; ROT DB 'RO' DB 'T'+80H DW GREAT-4 ROT: DW $+2 POP D POP H XTHL JMP DPUSH ; ************* ; * SPACE * ; ************* ; DB 85H ; SPACE DB 'USE DB 20H ; *************** ; * CURRENT * ; *************** ; DB 87H ; CURRENT DB 'CURREN' DB 'T'+80H DW CONT-0AH CURR: DW DOUSE DB 22H ; ************* ; * STATE * ; ************* ; DB 85H ; STATE DB 'STAT' DB 'ESPAC' DB 'E'+80H DW ROT-6 SPACE: DW DOCOL DW BL DW EMIT DW SEMIS ; ************ ; * -DUP * ; ************ ; DB 84H ; -DUP DB '-DU' DB 'P'+80H DW SPACE-8 DDUP: DW DOCOL DW DUP DW ZBRAN ; IF DW DDUP1-$ DW DUP ; ENDIF '+80H DW CURR-0AH STATE: DW DOUSE DB 24H ; ************ ; * BASE * ; ************ ; DB 84H ; BASE DB 'BAS' DB 'E'+80H DW STATE-8 BASE: DW DOUSE DB 26H ; DB 83H ; DPL DB 'DP' DB 'L'+80H DW BASE-7 DPL: DW DOUSE DB 28H DDUP1: DW SEMIS ; **************** ; * TRAVERSE * ; **************** ; DB 88H ; TRAVERSE DB 'TRAVERS' DB 'E'+80H DW DDUP-7 TRAV: DW DOCOL DW SWAP TRAV1: DW OVER ; BEGIN DW PLUS DW LIT DW 7FH DW OVER DW CAT DW LESS DW Z ; *********** ; * FLD * ; *********** ; DB 83H ; FLD DB 'FL' DB 'D'+80H DW DPL-6 FLD: DW DOUSE DB 2AH ; *********** ; * CSP * ; *********** ; DB 83H ; CSP DB 'CS' DB 'P'+80H DW FLD-6 CSPP: DW DOUSE DB 2CH BRAN ; UNTIL DW TRAV1-$ DW SWAP DW DROP DW SEMIS ; ************** ; * LATEST * ; ************** ; DB 86H ; LATEST DB 'LATES' DB 'T'+80H DW TRAV-0BH LATES: DW DOCOL DW CURR DW AT DW AT DW SEMIS ; *********** ; * ; ********** ; * R# * ; ********** ; DB 82H ; R# DB 'R' DB '#'+80H DW CSPP-6 RNUM: DW DOUSE DB 2EH ; *********** ; * HLD * ; *********** ; DB 83H ; HLD DB 'HL' DB 'D'+80H DW RNUM-5 HLD: DW DOUSE DW 30H ; ; END OF LFA * ; *********** ; DB 83H ; LFA DB 'LF' DB 'A'+80H DW LATES-9 LFA: DW DOCOL DW LIT DW 4 DW SUBB DW SEMIS ; *********** ; * CFA * ; *********** ; DB 83H ; CFA DB 'CF' DB 'A'+80H DW LFA-6 CFA: DW DOCOL DW TWO USER VARIABLES ; DB 82H ; 1+ DB '1' DB '+'+80H DW HLD-6 ONEP: DW DOCOL DW ONE DW PLUS DW SEMIS ; ********** ; * 2+ * ; ********** ; DB 82H ; 2+ DB '2' DB '+'+80H DW ONEP-5 TWOP: DW DOCOL DW TWO DW PLUS DW SEMIS DW SUBB DW SEMIS ; *********** ; * NFA * ; *********** ; DB 83H ; NFA DB 'NF' DB 'A'+80H DW CFA-6 NFA: DW DOCOL DW LIT DW 5 DW SUBB DW LIT DW -1 DW TRAV DW SEMIS ; *********** ; * PFA * ; *********** ; DB  ; ************ ; * HERE * ; ************ ; DB 84H ; HERE DB 'HER' DB 'E'+80H DW TWOP-5 HERE: DW DOCOL DW DP DW AT DW SEMIS ; ************* ; * ALLOT * ; ************* ; DB 85H ; ALLOT DB 'ALLO' DB 'T'+80H DW HER83H ; PFA DB 'PF' DB 'A'+80H DW NFA-6 PFA: DW DOCOL DW ONE DW TRAV DW LIT DW 5 DW PLUS DW SEMIS ; ************ ; * :CSP * ; ************ ; DB 84H ; STORE CSP DB '!CS' DB 'P'+80H DW PFA-6 SCSP: DW DOCOL DW SPAT DWE-7 ALLOT: DW DOCOL DW DP DW PSTOR DW SEMIS ; ********* ; * , * ; ********* ; DB 81H ; , DB ','+80H DW ALLOT-8 COMMA: DW DOCOL DW HERE DW STORE DW TWO DW ALLOT DW SEMIS ; ********** ; * C, * ; ********** ;  CSPP DW STORE DW SEMIS ; ************** ; * ?ERROR * ; ************** ; DB 86H ; ?ERROR DB '?ERRO' DB 'R'+80H DW SCSP-7 QERR: DW DOCOL DW SWAP DW ZBRAN ; IF DW QERR1-$ DW ERROR DW BRAN ; ELSE DW QERR2-$ QERR1: DW DROPDB 82H ; C, DB 'C' DB ','+80H DW COMMA-4 CCOMM: DW DOCOL DW HERE DW CSTOR DW ONE DW ALLOT DW SEMIS ; ; SUBROUTINE USED BY - AND < ; ; (HL) <- (HL) - (DE) SSUB: MOV A,L ; LB SUB E MOV L,A MOV A,H ; HB SBB D MOV H,A RET  ; ENDIF QERR2: DW SEMIS ; ************* ; * ?COMP * ; ************* ; DB 85H ; ?COMP DB '?COM' DB 'P'+80H DW QERR-9 QCOMP: DW DOCOL DW STATE DW AT DW ZEQU DW LIT DW 11H DW QERR DW SEMIS ; ************* ; * ?EXEC ; ********* ; * - * ; ********* ; DB 81H ; - DB '-'+80H DW CCOMM-5 SUBB: DW $+2 POP D ; (DE) <- (S1) = Y POP H ; (HL) <- (S2) = X CALL SSUB JMP HPUSH ; (S1) <- X - Y ; ********* ; * = * ; ********* ; DB 81H ; = DB '= * ; ************* ; DB 85H ; ?EXEC DB '?EXE' DB 'C'+80H DW QCOMP-8 QEXEC: DW DOCOL DW STATE DW AT DW LIT,12H DW QERR DW SEMIS ; ************** ; * ?PAIRS * ; ************** ; DB 86H ; ?PAIRS DB '?PAIR' DB 'S'+80H '+80H DW SUBB-4 EQUAL: DW DOCOL DW SUBB DW ZEQU DW SEMIS ; DB 81H ; < DB '<'+80H ; X < Y DW EQUAL-4 ; S2 S1 LESS: DW $+2 POP D ; (DE) <- (S1) = Y POP H ; (HL) <- (S2) = X MOV A,D ; IF X & Y HAVE SAME SIGNS XRA H JM LES1  DW QEXEC-8 QPAIR: DW DOCOL DW SUBB DW LIT DW 13H DW QERR DW SEMIS ; ************ ; * ?CSP * ; ************ ; DB 84H ; ?CSP DB '?CS' DB 'P'+80H DW QPAIR-9 QCSP: DW DOCOL DW SPAT DW CSPP DW AT DW SUBB DW LIT DW 14CALL SSUB ; (HL) <- X - Y LES1: INR H ; IF (HL) >= 0 DCR H JM LES2 LXI H,0 ; THEN X >= Y JMP HPUSH ; (S1) <- FALSE LES2: LXI H,1 ; ELSE X < Y JMP HPUSH ; (S1) <- TRUE ; ********** ; * U< * ; ********** ; DB 82H ; U< ( UNSIGNED < )H DW QERR DW SEMIS ; **************** ; * ?LOADING * ; **************** ; DB 88H ; ?LOADING DB '?LOADIN' DB 'G'+80H DW QCSP-7 QLOAD: DW DOCOL DW BLK DW AT DW ZEQU DW LIT,16H DW QERR DW SEMIS ; *************** ; *  DB 'U' DB '<'+80H DW LESS-4 ULESS: DW DOCOL,TDUP DW XORR,ZLESS DW ZBRAN,ULES1-$ ; IF DW DROP,ZLESS DW ZEQU DW BRAN,ULES2-$ ULES1: DW SUBB,ZLESS ; ELSE ULES2: DW SEMIS ; ENDIF ; ********* ; * > * ; ********* ; DB 81H ; >  COMPILE * ; *************** ; DB 87H ; COMPILE DB 'COMPIL' DB 'E'+80H DW QLOAD-0BH COMP: DW DOCOL DW QCOMP DW FROMR DW DUP DW TWOP DW TOR DW AT DW COMMA DW SEMIS ; ********* ; * [ * ; ********* ; DB 0C1H ; [ D*     B '['+80H DW COMP-0AH LBRAC: DW DOCOL DW ZERO DW STATE DW STORE DW SEMIS ; ********* ; * ] * ; ********* ; DB 81H ; ] DB ']'+80H DW LBRAC-4 RBRAC: DW DOCOL DW LIT,0C0H DW STATE,STORE DW SEMIS ; ************** ; * ENDIF DOTQ2: DW SEMIS ; ************** ; * EXPECT * ; ************** ; DB 86H ; EXPECT DB 'EXPEC' DB 'T'+80H DW DOTQ-5 EXPEC: DW DOCOL DW OVER DW PLUS DW OVER DW XDO ; DO EXPE1: DW KEY DW DUP DW LIT DW 0EH DW PORIG  SMUDGE * ; ************** ; DB 86H ; SMUDGE DB 'SMUDG' DB 'E'+80H DW RBRAC-4 SMUDG: DW DOCOL DW LATES DW LIT DW 20H DW TOGGL DW SEMIS ; *********** ; * HEX * ; *********** ; DB 83H ; HEX DB 'HE' DB 'X'+80H DW SMUDW AT DW EQUAL DW ZBRAN ; IF DW EXPE2-$ DW DROP DW DUP DW IDO DW EQUAL DW DUP DW FROMR DW TWO DW SUBB DW PLUS DW TOR DW ZBRAN ; IF DW EXPE6-$ DW LIT DW BELL DW BRAN ; ELSE DW EXPE7-$ EXPE6: DW LIT DW BSOUT ; ENDIF DG-9 HEX: DW DOCOL DW LIT DW 10H DW BASE DW STORE DW SEMIS ; *************** ; * DECIMAL * ; *************** ; DB 87H ; DECIMAL DB 'DECIMA' DB 'L'+80H DW HEX-6 DEC: DW DOCOL DW LIT DW 0AH DW BASE DW STORE DW SEMIS EXPE7: DW BRAN ; ELSE DW EXPE3-$ EXPE2: DW DUP DW LIT DW 0DH DW EQUAL DW ZBRAN ; IF DW EXPE4-$ DW LEAVE DW DROP DW BL DW ZERO DW BRAN ; ELSE DW EXPE5-$ EXPE4: DW DUP ; ENDIF EXPE5: DW IDO DW CSTOR DW ZERO DW IDO DW ONEP  ; *************** ; * (;CODE) * ; *************** ; DB 87H ; (;CODE) DB '(;CODE' DB ')'+80H DW DEC-0AH PSCOD: DW DOCOL DW FROMR DW LATES DW PFA DW CFA DW STORE DW SEMIS ; ************* ; * ;CODE * ; ************* DW STORE ; ENDIF EXPE3: DW EMIT DW XLOOP ; LOOP DW EXPE1-$ DW DROP DW SEMIS ; ************* ; * QUERY * ; ************* ; DB 85H ; QUERY DB 'QUER' DB 'Y'+80H DW EXPEC-9 QUERY: DW DOCOL DW TIB DW AT DW LIT DW 50H DW  ; DB 0C5H ; ;CODE DB ';COD' DB 'E'+80H DW PSCOD-0AH SEMIC: DW DOCOL DW QCSP DW COMP DW PSCOD DW LBRAC SEMI1: DW NOOP ; ( ASSEMBLER ) DW SEMIS ; *************** ; * * ; ************* ; DB 85H ; DOES> DB 'DOES' DB '>'+80H DW BUILD-0AH DOES: DW DOCOL DW FROMR DW LATES DW PFA DW STORE DW  GET NEXT DISK BLOCK DW ZERO,INN DW STORE DW BRAN DW NULL3-$ NULL6: DW BLK DW AT DW ZBRAN ; IF DW NULL1-$ DW ONE DW BLK DW PSTOR DW ZERO DW INN DW STORE DW BLK DW AT DW BSCR DW ONE DW SUBB DW ANDD DW ZEQU DW ZBRANPSCOD DODOE: LHLD RPP ; (HL) <- (RP) DCX H MOV M,B ; (R1) <- (IP) = PFA = (SUBSTITUTE CFA) DCX H MOV M,C SHLD RPP ; (RP) <- (RP) - 2 INX D ; (DE) <- PFA = (SUBSTITUTE CFA) XCHG MOV C,M ; (IP) <- (SUBSTITUTE CFA) INX H MOV B,M INX H  ; IF DW NULL2-$ DW QEXEC DW FROMR DW DROP ; ENDIF NULL2: DW BRAN ; ELSE DW NULL3-$ NULL1: DW FROMR DW DROP ; ENDIF NULL3: DW SEMIS ; ************ ; * FILL * ; ************ ; DB 84H ; FILL DB 'FIL' DB 'L'+80H DW NULL-4 F JMP HPUSH ; (S1) <- PFA+2 = SUBSTITUTE PFA ; ************* ; * COUNT * ; ************* ; DB 85H ; COUNT DB 'COUN' DB 'T'+80H DW DOES-8 COUNT: DW DOCOL DW DUP DW ONEP DW SWAP DW CAT DW SEMIS PAGE ; ************ ; * ILL: DW $+2 MOV L,C MOV H,B POP D POP B XTHL XCHG FILL1: MOV A,B ; BEGIN ORA C JZ FILL2 ; WHILE MOV A,L STAX D INX D DCX B JMP FILL1 ; REPEAT FILL2: POP B JMP NEXT ; ************* ; * ERASE * ; ************* ; DBTYPE * ; ************ ; DB 84H ; TYPE DB 'TYP' DB 'E'+80H DW COUNT-8 TYPE: DW DOCOL DW DDUP DW ZBRAN ; IF DW TYPE1-$ DW OVER DW PLUS DW SWAP DW XDO ; DO TYPE2: DW IDO DW CAT DW EMIT DW XLOOP ; LOOP DW TYPE2-$ DW BRAN ; 85H ; ERASE DB 'ERAS' DB 'E'+80H DW FILL-7 ERASEE: DW DOCOL DW ZERO DW FILL DW SEMIS ; ************** ; * BLANKS * ; ************** ; DB 86H ; BLANKS DB 'BLANK' DB 'S'+80H DW ERASEE-8 BLANK: DW DOCOL DW BL DW FILL D ELSE DW TYPE3-$ TYPE1: DW DROP ; ENDIF TYPE3: DW SEMIS PAGE ; ***************** ; * -TRAILING * ; ***************** ; DB 89H ; -TRAILING DB '-TRAILIN' DB 'G'+80H DW TYPE-7 DTRAI: DW DOCOL DW DUP DW ZERO DW XDO ; DO DTRA1: DW SEMIS ; ************ ; * HOLD * ; ************ ; DB 84H ; HOLD DB 'HOL' DB 'D'+80H DW BLANK-9 HOLD: DW DOCOL DW LIT DW -1 DW HLD DW PSTOR DW HLD DW AT DW CSTOR DW SEMIS ; *********** ; * PAD * ; ***********W OVER DW OVER DW PLUS DW ONE DW SUBB DW CAT DW BL DW SUBB DW ZBRAN ; IF DW DTRA2-$ DW LEAVE DW BRAN ; ELSE DW DTRA3-$ DTRA2: DW ONE DW SUBB ; ENDIF DTRA3: DW XLOOP ; LOOP DW DTRA1-$ DW SEMIS ; ************ ; * (.")  ; DB 83H ; PAD DB 'PA' DB 'D'+80H DW HOLD-7 PAD: DW DOCOL DW HERE DW LIT DW 44H DW PLUS DW SEMIS ; END OF BASIC RELOCATABLE MODULE END  * ; ************ ; DB 84H ; (.") DB '(."' DB ')'+80H DW DTRAI-0CH PDOTQ: DW DOCOL DW RR DW COUNT DW DUP DW ONEP DW FROMR DW PLUS DW TOR DW TYPE DW SEMIS ; ********* ; * . * ; ********* ; DB 0C2H ; ." DB '.' ( **** HEXDUMP -- DUMP MEMORY IN HEX WITH ASCII PRINTOUT PACKAGE *** ) ( UPDATED: 12/16/83 BY NAA ) ( TEST KEYBOARD: PAUSES ON SPACE KEY, "F"=TRUE FOR ESCAPE KEY) : ?PAUSE ?TERMINAL DUP ( --> f ) IF DROP KEY DUP BL = IDB '"'+80H DW PDOTQ-7 DOTQ: DW DOCOL DW LIT DW 22H DW STATE DW AT DW ZBRAN ; IF DW DOTQ1-$ DW COMP DW PDOTQ DW WORD DW HERE DW CAT DW ONEP DW ALLOT DW BRAN ; ELSE DW DOTQ2-$ DOTQ1: DW WORD DW HERE DW COUNT DW TYPE ; F DROP KEY ENDIF 27 = ( ESCAPE KEY) ENDIF ; ( Prints the number in hex: f=0; 2 digits, =0; 4 digits ) : .H. BASE @ >R 16 BASE ! >R S->D <# # # R> IF # # ENDIF #> TYPE SPACE R> BASE +     ! ; ( Test for "n1" within "n2" and "n3") ( n1 n2 n3 --> f ) : WITHIN >R 1 - OVER < SWAP R> 1+ < AND ; ( Prints the character if within printing range) ( c --> ) : .ASC. 127 AND DUP BL 125 WITHIN 0= IF DROP  ORIG: NOP JMP CLD ; VECTOR TO COLD START ; NOP JMP WRM ; VECTOR TO WARM START ; DB FIGREL ; FIG RELEASE # DB FIGREV ; FIG REVISION # DB USRVER ; USER VERSION # DB 0EH ; IMPLEMENTATION ATTRIBUTES DW TASK-7 ; TOPMOST WORD IN FORTH VOCABUL 46 ( period) ENDIF EMIT ; ( Prints hex numbers: 2HEX = 2 digits, 4HEX = 4 digits) ( u --> ) : 2HEX 0 .H. ; : 4HEX 1 .H. ; ( Dump memory in hex format ) ( addr count --> ) ( Press: SPACE to pause dump, ESCAPE to exit duARY DW BSIN ; BKSPACE CHARACTER DW INITR0 ; INIT (UP) ;<<<<<< FOLLOWING USED BY COLD; ; MUST BE IN SAME ORDER AS USER VARIABLES DW INITS0 ; INIT (S0) DW INITR0 ; INIT (R0) DW INITS0 ; INIT (TIB) DW 20H ; INIT (WIDTH) DW 1 ; INIT (WARNING)mp. ) : DUMP CR OVER + SWAP DO ( new line) CR I 4HEX I 16 + I 2DUP SPACE DO ( one line of hex dump) I C@ 2HEX LOOP SPACE DO ( one line of ASCII dump) I C@ .ASC. LOOP ?PAU DW INITDP ; INIT (FENCE) DW INITDP ; INIT (DP) DW FORTH+6 ; INIT (VOC-LINK) ;<<<<<< END DATA USED BY COLD DW 5H,0B320H ; CPU NAME ( HW,LW ) ; ( 32 BIT, BASE 36 INTEGER ) ; ; ; +---------------+ ; B +ORIGIN | . . .W:I.E.B.A| IMPLEMESE IF LEAVE ENDIF 16 ( offset) +LOOP CR CR ; ;S NTATION ; +---------------+ ATTRIBUTES ; ^ ^ ^ ^ ^ ; | | | | +-- PROCESSOR ADDR = ; | | | | { 0 BYTE | 1 WORD } ; | | | +---- HIGH BYTE AT ; | | | { 0 LOW ADDR | ; | | | 1 HIGH ADDR } ; | | +------ ADDR MUST BE EVEN ; | | { 0 YES | 1 NO } ; | +-------- INTERPRETER IS ; | { 0 PRE | 1 POST } ; | INCREMENTING ; +---------- { 0 ABOVE SUFFICIENT ; | 1 OTHER DIFFER- ; ENCES EXIST } ; PAGE ; ;------------------------------------------------------ ; ; FORTH REGISTERS ; ; FORTH 8080 FORTH PRESERVATION RULES ; ----- ---- ------------------------ ; IP BC SHOULD BE PRESERVED ACROSS ; FORTH  TITLE '8080 FIG-FORTH 1.5 (01/05/84)' ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; ; 8080 FIG-FORTH ; ; FORTH COMP ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; ; ALL PUBLICATIONS OF THE FORTH INTEREST GROUP ; ARE PUBLIC DOMAIN. THEY MWORDS ; W DE SOMETIMES OUTPUT FROM NEXT ; MAY BE ALTERED BEFORE JMP'ING TO NEXT ; INPUT ONLY WHEN 'DPUSH' CALLED ; SP SP SHOULD BE USED ONLY AS DATA STACK ; ACROSS FORTH WORDS ; MAY BE USED WITHIN FORTH WORDS ; IF RESTORED BEFORE 'NEXTAY BE FURTHER ; DISTRIBUTED BY THE INCLUSION OF THIS CREDIT ; NOTICE: ; ; THIS PUBLICATION HAS BEEN MADE AVAILABLE BY THE ; FORTH INTEREST GROUP ; P. O. BOX 1105 ; SAN CARLOS, CA 94070 ; ; MODIFICATIONS BY NICK AVDONIN ; 1. RE' ; HL NEVER OUTPUT FROM NEXT ; INPUT ONLY WHEN 'HPUSH' CALLED ; UP: DW INITR0 ; USER AREA POINTER RPP: DW INITR0 ; RETURN STACK POINTER ; ;------------------------------------------------------ ; ; COMMENT CONVENTIONS: ; ; = MEANS "IS EQUAL MOVED DISK I/O, BLOCK STRUCTURE ; ADDED FORTH COMP, CP/M STRUCTURE. ; FORTH COMP, COPYRIGHT 1984 BY NICK AVDONIN ; 2. INITIALIZE WARNING TO 1 -- DISK AVAILABLE ; 3. 'COLD' SHOULD NOT EMPTY-BUFFERS ; 4. INPUT DELETE CHANGED TO BACKSPACE -- TO" ; <- MEANS ASSIGNMENT ; ; NAME = ADDRESS OF NAME ; (NAME) = CONTENTS AT NAME ; ((NAME))= INDIRECT CONTENTS ; ; CFA = ADDRESS OF CODE FIELD ; LFA = ADDRESS OF LINK FIELD ; NFA = ADDR OF START OF NAME FIELD ; PFA = ADDR OF START OF PARAMETER FI08H PAGE ;---------------------------------------------------------- ; ; RELEASE & VERSION NUMBERS ; FIGREL EQU 1 ; FIG RELEASE # FIGREV EQU 5 ; FIG REVISION # USRVER EQU 0 ; USER VERSION # ; ; ASCII CHARACTERS USED ; ABL EQU 20H ; SPACE ELD ; ; S1 = ADDR OF 1ST WORD OF PARAMETER STACK ; S2 = ADDR OF 2ND WORD OF PARAMETER STACK ; R1 = ADDR OF 1ST WORD OF RETURN STACK ; R2 = ADDR OF 2ND WORD OF RETURN STACK ; ( ABOVE STACK POSITIONS VALID BEFORE & AFTER EXECUTION ; OF ANY WORD, NOT DACR EQU 0DH ; CARRIAGE RETURN ADOT EQU 02EH ; PERIOD BELL EQU 07H ; (^G) BSIN EQU 08H ; INPUT BACKSPACE CHR = (^H)--MOD NAA BSOUT EQU 08H ; OUTPUT BACKSPACE (^H) DLE EQU 10H ; (^P) LF EQU 0AH ; LINE FEED FF EQU 0CH ; FORM FEED (^L) ; ; MEMORY ALLOURING. ) ; ; LSB = LEAST SIGNIFICANT BIT ; MSB = MOST SIGNIFICANT BIT ; LB = LOW BYTE ; HB = HIGH BYTE ; LW = LOW WORD ; HW = HIGH WORD ; ( MAY BE USED AS SUFFIX TO ABOVE NAMES ) ; PAGE ;-------------------------------------------------- ; ; CATION ; EM EQU 7A00H ; TOP OF MEMORY + 1 = LIMIT NSCR EQU 2 ; NUMBER OF 1024 BYTE SCREENS KBBUF EQU 1024 ; DATA BYTES PER DISK BUFFER US EQU 40H ; USER VARIABLES SPACE RTS EQU 0A0H ; RETURN STACK & TERM BUFF SPACE ; CO EQU KBBUF+4 ; DISK BUFFERNEXT, THE FORTH ADDRESS INTERPRETER ; ( POST INCREMENTING VERSION ) ; ; ; DPUSH: PUSH D HPUSH: PUSH H NEXT: CNEXT: LDAX B ;(W) <- ((IP)) INX B ;(IP) <- (IP)+2 MOV L,A LDAX B INX B MOV H,A ; (HL) <- CFA NEXT1: MOV E,M ;(PC) <- ((W)) I + 2 HEADER + 2 TAIL NBUF EQU NSCR*400H/KBBUF ; NUMBER OF BUFFERS BUF1 EQU EM-CO*NBUF ; ADDR FIRST DISK BUFFER INITR0 EQU BUF1-US ; (R0) INITS0 EQU INITR0-RTS ; (S0) ; PAGE ; ;------------------------------------------------------- ; ORG 0H NX H MOV D,M XCHG PCHL ; NOTE: (DE) = CFA+1 PAGE ; FORTH DICTIONARY ; ; ; DICTIONARY FORMAT: ; ; BYTE ; ADDRESS NAME CONTENTS ; ------- ---- -------- ; ( MSB=1 ; ( P=PRECEDENCE BIT ; ( S=SMUDGE BIT ; NFA NAM,     E FIELD 1PS < NAME LENGTH ; 0<1CHAR> MSB=0, NAME'S 1ST CHAR ; 0<2CHAR> ; ... ; 1 MSB=1, NAME'S LAST CHR ; LFA LINK FIELD = PREVIOUS WORD'S NFA ; ;LABEL: CFA CODE FIELD = ADDR CPU CODE ; DR NEXT CHR IN STRING INX D ; (DE) <- ADDR NEXT CHR IN NF LDAX D XRA M ; IGNORE MSB ADD A JNZ PFIN3 ; NO MATCH JNC PFIN2 ; MATCH SO FAR, LOOP AGAIN LXI H,5 ; STRING MATCHES DAD D ; ((SP)) <- PFA XTHL ; ; BACK UP TO LENGTH BYTE OF NF =  ; PFA PARAMETER <1PARAM> 1ST PARAMETER BYTE ; FIELD <2PARAM> ; ... ; ; DP0: DB 83H ; LIT DB 'LI' DB 'T'+80H DW 0 ; ZERO LINK LIT: DW $+2 ;(S1) <- ((IP)) LDAX B ; (HL) <- ((IP)) = LITERAL INX B ; (IP) <- (IP) + 2 MOV L,NFA PFIN6: DCX D LDAX D ORA A JP PFIN6 ; IF MSB = 1 THEN (DE) = NFA MOV E,A ; (DE) <- LENGTH BYTE MVI D,0 LXI H,1 ; (HL) <- TRUE JMP DPUSH ; RETURN, NF FOUND ; ABOVE NF NOT A MATCH, TRY ANOTHER PFIN3: JC PFIN5 ; IF NOT END OF NF PFIN4: IA ; LB LDAX B ; HB INX B MOV H,A JMP HPUSH ; (S1) <- (HL) ; DB 87H ; EXECUTE DB 'EXECUT' DB 'E'+80H DW LIT-6 EXEC: DW $+2 POP H ; (HL) <- (S1) = CFA JMP NEXT1 ; DB 86H ; BRANCH DB 'BRANC' DB 'H'+80H DW EXEC-0AH BRAN: DW $+2NX D ; THEN FIND END OF NF LDAX D ORA A JP PFIN4 PFIN5: INX D ; (DE) <- LFA XCHG MOV E,M ; (DE) <- (LFA) INX H MOV D,M MOV A,D ORA E ; IF (LFA) <> 0 JNZ PFIN1 ; THEN TRY PREVIOUS DICT. DEF. ; ; ELSE END OF DICTIONARY POP H ; DISCA ;(IP) <- (IP) + ((IP)) BRAN1: MOV H,B ; (HL) <- (IP) MOV L,C MOV E,M ; (DE) <- ((IP)) = BRANCH OFFSET INX H MOV D,M DCX H DAD D ; (HL) <- (HL) + ((IP)) MOV C,L ; (IP) <- (HL) MOV B,H JMP NEXT ; DB 87H ; 0BRANCH DB '0BRANC' DB 'H'RD STRING ADDR LXI H,0 ; (HL) <- FALSE JMP HPUSH ; RETURN, NO MATCH FOUND PAGE ; *************** ; * ENCLOSE * ; *************** ; ; MODIFIED FROM THE 'FIG' VERSION TO ALLOW ; SEARCHES UP TO 65535 BYTES. ; (PREVIOUSLY ON 8-BITS; 256 +80H DW BRAN-9 ZBRAN: DW $+2 POP H MOV A,L ORA H JZ BRAN1 ; IF (S1)=0 THEN BRANCH INX B ; ELSE SKIP BRANCH OFFSET INX B JMP NEXT ; DB 86H ; (LOOP) DB '(LOOP' DB ')'+80H DW ZBRAN-0AH XLOOP: DW $+2 LXI D,1 ; (DE) <- INCREMENT XLBYTES) ; DB 87H ; ENCLOSE DB 'ENCLOS' DB 'E'+80H DW PFIND-9 ENCL: DW $+2 POP D ; (DE) <- (S1) = DELIMITER CHAR POP H ; (HL) <- (S2) = ADDR TEXT TO SCAN PUSH H ; (S4) <- ADDR MOV A,E LXI D,-1 ; INITIALIZE CHR OFFSET COUNTER DCX H ; (HLOO1: LHLD RPP ; ((HL)) = INDEX MOV A,M ; INDEX <- INDEX + INCR ADD E MOV M,A MOV E,A INX H MOV A,M ADC D MOV M,A INX H ; ((HL)) = LIMIT INR D DCR D MOV D,A ; (DE) <- NEW INDEX JM XLOO2 ; IF INCR > 0 MOV A,E SUB M ; THEN (A) <-) <- ADDR-1 ; ; SKIP OVER LEADING DELIMITER CHRS ENCL1: INX H INX D CMP M ; IF TEXT CHR = DELIM CHR JZ ENCL1 ; THEN LOOP AGAIN ; ; ELSE NON-DELIM CHR FOUND ; PUSH D ; OFFSET TO 1ST NON-DELIMITER CHAR PUSH B ; SAVE 'IP' MOV B,A ; (B) <-  INDEX - LIMIT MOV A,D INX H SBB M JMP XLOO3 XLOO2: MOV A,M ; ELSE (A) <- LIMIT - INDEX SUB E INX H MOV A,M SBB D ; ; IF (A) < 0 XLOO3: JM BRAN1 ; THEN LOOP AGAIN INX H ; ELSE DONE SHLD RPP ; DISCARD R1 & R2 INX B ; SKIP BRANCH ODELIM CHR MOV A,M ; IF 1ST NON-DELIM = NULL ANA A JNZ ENCL2 ; FOUND NULL (00), STOP THE SEARCH ; INX D ; CHARACTER FOLLOWING NULL POP B ; GET BACK 'IP' PUSH D DCX D ; (S1) <- OFFSET TO NULL PUSH D JMP NEXT ; ELSE TEXT CONTAINS NON-FFSET INX B JMP NEXT ; DB 87H ; (+LOOP) DB '(+LOOP' DB ')'+80H DW XLOOP-9 XPLOO: DW $+2 POP D ; (DE) <- INCR JMP XLOO1 ; DB 84H ; (DO) DB '(DO' DB ')'+80H DW XPLOO-0AH XDO: DW $+2 LHLD RPP ; (RP) <- (RP) - 4 DCX H DCX H DELIM & NON-NULL CHR ; ENCL2: MOV A,B ; (A) <- DELIM CHR INX H ; (HL) <- ADDR NEXT CHR INX D ; (DE) <- OFFSET TO NEXT CHR CMP M ; IF NEXT CHR <> DELIM CHR JZ ENCL4 MOV A,M ; AND IF NEXT CHR <> NULL ANA A JNZ ENCL2 ; THEN CONTINUE SCAN ; DCX H DCX H SHLD RPP POP D ; (R1) <- (S1) = INIT INDEX MOV M,E INX H MOV M,D POP D ; (R2) <- (S2) = LIMIT INX H MOV M,E INX H MOV M,D JMP NEXT ; DB 81H ; I DB 'I'+80H DW XDO-7 IDO: DW $+2 ;(S1) <- (R1) , (R1) UNCHANGED LHLELSE CHARACTER = NULL (00) ; ENCL3: POP B ; GET BACK 'IP' PUSH D ; (S2) <- OFFSET TO NULL PUSH D ; (S1) <- OFFSET TO NULL JMP NEXT ; ELSE CHARACTER = DELIMITER CHARACTER ; ENCL4: POP B ; GET BACK 'IP' PUSH D ; (S2) <- OFFSET TO BYTE ; FOD RPP MOV E,M ; (DE) <- (R1) INX H MOV D,M PUSH D ; (S1) <- (DE) JMP NEXT ; DB 85H ; DIGIT DB 'DIGI' DB 'T'+80H DW IDO-4 DIGIT: DW $+2 POP H ; (L) <- (S1)LB = ASCII CHR TO BE ; CONVERTED POP D ; (DE) <- (S2) = BASE VALUE MOV ALLOWING TEXT INX D ; (S1) <- OFFSET TO 2 BYTES AFTER ; END OF WORD PUSH D JMP NEXT PAGE DB 84H ; EMIT DB 'EMI' DB 'T'+80H DW ENCL-0AH EMIT: DW DOCOL DW PEMIT DW ONE,OUTT DW PSTOR,SEMIS ; DB 83H ; KEY DB 'KE' DB 'Y,E SUI 30H ; IF CHR > "0" JM DIGI2 CPI 0AH ; AND IF CHR > "9" JM DIGI1 SUI 7 CPI 0AH ; AND IF CHR >= "A" JM DIGI2 ; ; THEN VALID NUMERIC OR ALPHA CHR DIGI1: CMP L ; IF < BASE VALUE JP DIGI2 ; ; THEN VALID DIGIT CHR MOV E,A ; (S2) <'+80H DW EMIT-7 KEY: DW $+2 JMP PKEY ; DB 89H ; ?TERMINAL DB '?TERMINA' DB 'L'+80H DW KEY-6 QTERM: DW $+2 LXI H,0 JMP PQTER ; DB 82H ; CR DB 'C' DB 'R'+80H DW QTERM-0CH CR: DW DOCOL DW ZERO DW OUTT,STORE ; CLEAR CHAR COUNT - (DE) = CONVERTED DIGIT LXI H,1 ; (S1) <- TRUE JMP DPUSH ; ; ELSE INVALID DIGIT CHR DIGI2: MOV L,H ; (HL) <- FALSE JMP HPUSH ; (S1) <- FALSE ; DB 86H ; (FIND) (2-1)FAILURE DB '(FIND' ; (2-3)SUCCESS DB ')'+80H DW DIGIT-8 PFIND: DW $+2  DW PCR,SEMIS ; DB 85H ; CMOVE DB 'CMOV' DB 'E'+80H DW CR-5 CMOVE: DW $+2 MOV L,C ; (HL) <- (IP) MOV H,B POP B ; (BC) <- (S1) = #CHRS POP D ; (DE) <- (S2) = DEST ADDR XTHL ; (HL) <- (S3) = SOURCE ADDR ; ; (S1) <- (IP) JMP CMOV2 ; POP D ; (DE) <- NFA PFIN1: POP H ; (HL) <- STRING ADDR PUSH H ; SAVE STRING ADDR FOR NEXT ITERATION LDAX D XRA M ; CHECK LENGTHS & SMUDGE BIT ANI 3FH JNZ PFIN4 ; LENGTHS DIFFERENT ; ; LENGTHS MATCH, CHECK EACH CHR PFIN2: INX H ; (HL) <- AD RETURN IF #CHRS = 0 CMOV1: MOV A,M ; ((DE)) <- ((HL)) INX H ; INC SOURCE ADDR STAX D INX D ; INC DEST ADDR DCX B ; DEC #CHRS CMOV2: MOV A,B ORA C JNZ CMOV1 ; REPEAT IF #CHRS <> 0 POP B ; RESTORE (IP) FROM (S1) JMP NEXT ; DB 82H ; U* 1-     6X16 UNSIGNED MULTIPLY DB 'U' ; AVG EXECUTION TIME = 994 CYCLES DB '*'+80H DW CMOVE-8 USTAR: DW $+2 POP D ; (DE) <- MPLIER POP H ; (HL) <- MPCAND PUSH B ; SAVE IP MOV B,H MOV A,L ; (BA) <- MPCAND CALL MPYX ; (AHL)1 <- MPCAND.LB * MPLIER  DB '!'+80H DW RPAT-6 RPSTO: DW $+2 ;(RP) <- (R0) ( USER VARIABLE ) LHLD UP ; (HL) <- USER VARIABLE BASE ADDR LXI D,8 DAD D ; (HL) <- R0 MOV E,M ; (DE) <- (R0) INX H MOV D,M XCHG SHLD RPP ; (RP) <- (R0) JMP NEXT ; DB 82H ; ;S DB  ; 1ST PARTIAL PRODUCT PUSH H ; SAVE (HL)1 MOV H,A MOV A,B MOV B,H ; SAVE (A)1 CALL MPYX ; (AHL)2 <- MPCAND.HB * MPLIER ; 2ND PARTIAL PRODUCT POP D ; (DE) <- (HL)1 MOV C,D ; (BC) <- (AH)1 ; FORM SUM OF PARTIALS: ; (A';' DB 'S'+80H DW RPSTO-6 SEMIS: DW $+2 ;(IP) <- (R1) LHLD RPP MOV C,M ; (BC) <- (R1) INX H MOV B,M INX H SHLD RPP ; (RP) <- (RP) + 2 JMP NEXT ; DB 85H ; LEAVE DB 'LEAV' DB 'E'+80H DW SEMIS-5 LEAVE: DW $+2 ;LIMIT <- INDEX LHLHL) 1 ; + (AHL) 2 ; -------- ; (AHLE) DAD B ; (HL) <- (HL)2 + (AH)1 ACI 0 ; (AHLE) <- (BA) * (DE) MOV D,L MOV L,H MOV H,A ; (HLDE) <- MPLIER * MPCAND POP B ; RESTORE IP PUSH D ; (S2) <- PRODUCT.LW JMP HPUSH ; (S1) <- PRODUCT.HW D RPP MOV E,M ; (DE) <- (R1) = INDEX INX H MOV D,M INX H MOV M,E ; (R2) <- (DE) = LIMIT INX H MOV M,D JMP NEXT ; DB 82H ; >R DB '>' DB 'R'+80H DW LEAVE-8 TOR: DW $+2 ;(R1) <- (S1) POP D ; (DE) <- (S1) LHLD RPP DCX H ; (RP) < ; ; MULTIPLY PRIMITIVE ; (AHL) <- (A) * (DE) ; #BITS = 24 8 16 MPYX: LXI H,0 ; (HL) <- 0 = PARTIAL PRODUCT.LW MVI C,8 ; LOOP COUNTER MPYX1: DAD H ; LEFT SHIFT (AHL) 24 BITS RAL JNC MPYX2 ; IF NEXT MPLIER BIT = 1 DAD D ; THEN ADD MPCAND - (RP) - 2 DCX H SHLD RPP MOV M,E ; ((HL)) <- (DE) INX H MOV M,D JMP NEXT ; DB 82H ; R> DB 'R' DB '>'+80H DW TOR-5 FROMR: DW $+2 ;(S1) <- (R1) LHLD RPP MOV E,M ; (DE) <- (R1) INX H MOV D,M INX H SHLD RPP ; (RP) <- (RP) + 2ACI 0 MPYX2: DCR C ; IF NOT LAST MPLIER BIT JNZ MPYX1 ; THEN LOOP AGAIN RET ; ELSE DONE ; DB 82H ; U/ DB 'U' DB '/'+80H DW USTAR-5 USLAS: DW $+2 LXI H,4 DAD SP ; ((HL)) <- NUMERATOR.LW MOV E,M ; (DE) <- NUMER.LW MOV M,C ; SAVE IP ON PUSH D ; (S1) <- (DE) JMP NEXT ; DB 81H ; R DB 'R'+80H DW FROMR-5 RR: DW IDO+2 ; DB 82H ; 0= DB '0' DB '='+80H DW RR-4 ZEQU: DW $+2 POP H ; (HL) <- (S1) MOV A,L ORA H ; IF (HL) = 0 LXI H,0 ; THEN (HL) <- FALSE JNZ ZEQU1 I STACK INX H MOV D,M MOV M,B POP B ; (BC) <- DENOMINATOR POP H ; (HL) <- NUMER.HW MOV A,L SUB C ; IF NUMER >= DENOM MOV A,H SBB B JC USLA1 LXI H,0FFFFH ; THEN OVERFLOW LXI D,0FFFFH ; SET REM & QUOT TO MAX JMP USLA7 USLA1: MVI A,1NX H ; ELSE (HL) <- TRUE ZEQU1: JMP HPUSH ; (S1) <- (HL) ; DB 82H ; 0< DB '0' DB '<'+80H DW ZEQU-5 ZLESS: DW $+2 POP H ; (HL) <- (S1) DAD H ; IF (HL) >= 0 LXI H,0 ; THEN (HL) <- FALSE JNC ZLES1 INX H ; ELSE (HL) <- TRUE ZLES1: JMP HPU6 ; LOOP COUNTER USLA2: DAD H ; LEFT SHIFT (HLDE) THRU CARRY RAL XCHG DAD H JNC USLA3 INX D ANA A USLA3: XCHG ; SHIFT DONE RAR ; RESTORE 1ST CARRY PUSH PSW ; SAVE COUNTER JNC USLA4 ; IF CARRY = 1 MOV A,L ; THEN (HL) <- (HL) - (BC) SH ; (S1) <- (HL) ; DB 81H ; + DB '+'+80H DW ZLESS-5 PLUS: DW $+2 ;(S1) <- (S1) + (S2) POP D POP H DAD D JMP HPUSH ; DB 82H ; D+ (4-2) DB 'D' ; XLW XHW YLW YHW --- SLW SHW DB '+'+80H ; S4 S3 S2 S1 S2 S1 DW PLUS-4 DP SUB C MOV L,A MOV A,H SBB B MOV H,A JMP USLA5 USLA4: MOV A,L ; ELSE TRY (HL) <- (HL) - (BC) SUB C MOV L,A MOV A,H SBB B ; (HL) <- PARTIAL REMAINDER MOV H,A JNC USLA5 DAD B ; UNDERFLOW, RESTORE DCX D USLA5: INX D ; INC QUOT USLLUS: DW $+2 LXI H,6 DAD SP ; ((HL)) = XLW MOV E,M ; (DE) = XLW MOV M,C ; SAVE IP ON STACK INX H MOV D,M MOV M,B POP B ; (BC) <- YHW POP H ; (HL) <- YLW DAD D XCHG ; (DE) <- YLW + XLW = SUM.LW POP H ; (HL) <- XHW MOV A,L ADC C A6: POP PSW ; RESTORE COUNTER DCR A ; IF COUNTER > 0 JNZ USLA2 ; THEN LOOP AGAIN USLA7: POP B ; ELSE DONE, RESTORE IP PUSH H ; (S2) <- REMAINDER PUSH D ; (S1) <- QUOTIENT JMP NEXT ; DB 83H ; AND DB 'AN' DB 'D'+80H DW USLAS-5 ANDD: DW $ MOV L,A ; (HL) <- YHW + XHW + CARRY MOV A,H ADC B MOV H,A POP B ; RESTORE IP PUSH D ; (S2) <- SUM.LW JMP HPUSH ; (S1) <- SUM.HW ; DB 85H ; MINUS DB 'MINU' DB 'S'+80H DW DPLUS-5 MINUS: DW $+2 ;(S1) <- -(S1) ( 2'S COMPLEMENT ) POP H +2 ; (S1) <- (S1) AND (S2) POP D POP H MOV A,E ANA L MOV L,A MOV A,D ANA H MOV H,A JMP HPUSH ; DB 82H ; OR DB 'O' DB 'R'+80H DW ANDD-6 ORR: DW $+2 ; (S1) <- (S1) OR (S2) POP D POP H MOV A,E ORA L MOV L,A MOV A,D OR MOV A,L CMA MOV L,A MOV A,H CMA MOV H,A INX H JMP HPUSH ; DB 86H ; DMINUS DB 'DMINU' DB 'S'+80H DW MINUS-8 DMINU: DW $+2 POP H ; (HL) <- HW POP D ; (DE) <- LW SUB A SUB E ; (DE) <- 0 - (DE) MOV E,A MVI A,0 SBB D MOA H MOV H,A JMP HPUSH ; DB 83H ; XOR DB 'XO' DB 'R'+80H DW ORR-5 XORR: DW $+2 ; (S1) <- (S1) XOR (S2) POP D POP H MOV A,E XRA L MOV L,A MOV A,D XRA H MOV H,A JMP HPUSH ; DB 83H ; SP@ DB 'SP' DB '@'+80H DW XORR-6 SPV D,A MVI A,0 SBB L ; (HL) <- 0 - (HL) MOV L,A MVI A,0 SBB H MOV H,A PUSH D ; (S2) <- LW JMP HPUSH ; (S1) <- HW ; DB 84H ; OVER DB 'OVE' DB 'R'+80H DW DMINU-9 OVER: DW $+2 POP D POP H PUSH H JMP DPUSH ; DB 84H ; DROP AT: DW $+2 ;(S1) <- (SP) LXI H,0 DAD SP ; (HL) <- (SP) JMP HPUSH ; (S1) <- (HL) ; DB 83H ; STACK POINTER STORE DB 'SP' DB '!'+80H DW SPAT-6 SPSTO: DW $+2 ;(SP) <- (S0) ( USER VARIABLE ) LHLD UP ; (HL) <- USER VAR BASE ADDR LXI D,6 DADDB 'DRO' DB 'P'+80H DW OVER-7 DROP: DW $+2 POP H JMP NEXT ; DB 84H ; SWAP DB 'SWA' DB 'P'+80H DW DROP-7 SWAP: DW $+2 POP H XTHL JMP HPUSH ; DB 83H ; DUP DB 'DU' DB 'P'+80H DW SWAP-7 DUP: DW $+2 POP H PUSH H JMP HPUS D ; (HL) <- S0 MOV E,M ; (DE) <- (S0) INX H MOV D,M XCHG SPHL ; (SP) <- (S0) JMP NEXT ; DB 83H ; RP@ DB 'RP' DB '@'+80H DW SPSTO-6 RPAT: DW $+2 ;(S1) <- (RP) LHLD RPP JMP HPUSH ; DB 83H ; RETURN STACK POINTER STORE DB 'RP' H ; DB 84H ; 2DUP DB '2DU' DB 'P'+80H DW DUP-6 TDUP: DW $+2 POP H POP D PUSH D PUSH H JMP DPUSH ; DB 82H ; PLUS STORE DB '+' DB '!'+80H DW TDUP-7 PSTOR: DW $+2 ;((S1)) <- ((S1)) + (S2) POP H ; (HL) <- (S1) = ADDR POP D ; (.     DE) <- (S2) = INCR MOV A,M ; ((HL)) <- ((HL)) + (DE) ADD E MOV M,A INX H MOV A,M ADC D MOV M,A JMP NEXT ; DB 86H ; TOGGLE DB 'TOGGL' DB 'E'+80H DW PSTOR-5 TOGGL: DW $+2 ;((S2)) <- ((S2)) XOR (S1)LB POP D ; (E) <- BYTE MASK POP**** ; * 1 * ; ********* ; DB 81H ; 1 DB '1'+80H DW ZERO-4 ONE: DW DOCON DW 1 ; ********* ; * 2 * ; ********* ; DB 81H ; 2 DB '2'+80H DW ONE-4 TWO: DW DOCON DW 2 ; ********* ; * 3 * ; ********* ; DB 81H ;  H ; (HL) <- ADDR MOV A,M XRA E MOV M,A ; (ADDR) <- (ADDR) XOR (E) JMP NEXT ; DB 81H ; @ DB '@'+80H DW TOGGL-9 AT: DW $+2 ;(S1) <- ((S1)) POP H ; (HL) <- ADDR MOV E,M ; (DE) <- (ADDR) INX H MOV D,M PUSH D ; (S1) <- (DE) JMP NEXT3 DB '3'+80H DW TWO-4 THREE: DW DOCON DW 3 ; ********** ; * BL * ; ********** ; DB 82H ; BL DB 'B' DB 'L'+80H DW THREE-4 BL: DW DOCON DW 20H ; *********** ; * C/L * ; *********** ; DB 83H ; C/L ( CHARACTERS/LINE  ; DB 82H ; C@ DB 'C' DB '@'+80H DW AT-4 CAT: DW $+2 ;(S1) <- ((S1))LB POP H ; (HL) <- ADDR MOV L,M ; (HL) <- (ADDR)LB MVI H,0 JMP HPUSH ; DB 82H ; 2@ DB '2' DB '@'+80H DW CAT-5 TAT: DW $+2 POP H ; (HL) <- ADDR HW LXI D,2 ) DB 'C/' DB 'L'+80H DW BL-5 CSLL: DW DOCON DW 64 ; ************* ; * FIRST * ; ************* ; DB 85H ; FIRST DB 'FIRS' DB 'T'+80H DW CSLL-6 FIRST: DW DOCON DW BUF1 ; ************* ; * LIMIT * ; ************* ; DAD D ; (HL) <- ADDR LW MOV E,M ; (DE) <- LW INX H MOV D,M PUSH D ; (S2) <- LW LXI D,-3 ; (HL) <- ADDR HW DAD D MOV E,M ; (DE) <- HW INX H MOV D,M PUSH D ; (S1) <- HW JMP NEXT ; DB 81H ; STORE DB '!'+80H DW TAT-5 STORE: DW $+2 DB 85H ; LIMIT DB 'LIMI' DB 'T'+80H DW FIRST-8 LIMIT: DW DOCON DW EM ; ************* ; * B/BUF * ; ************* ; DB 85H ; B/BUF ( BYTES/BUFFER ) DB 'B/BU' DB 'F'+80H DW LIMIT-8 BBUF: DW DOCON DW KBBUF ; ************ ;((S1)) <- (S2) POP H ; (HL) <- (S1) = ADDR POP D ; (DE) <- (S2) = VALUE MOV M,E ; ((HL)) <- (DE) INX H MOV M,D JMP NEXT ; DB 82H ; C STORE DB 'C' DB '!'+80H DW STORE-4 CSTOR: DW $+2 ;((S1))LB <- (S2)LB POP H ; (HL) <- (S1) = ADDR * ; * B/SCR * ; ************* ; DB 85H ; B/SCR ( BUFFERS/SCREEN ) DB 'B/SC' DB 'R'+80H DW BBUF-8 BSCR: DW DOCON DW 400H/KBBUF ; *************** ; * +ORIGIN * ; *************** ; DB 87H ; +ORIGIN DB '+ORIGI' DB 'N'+80H  POP D ; (DE) <- (S2) = BYTE MOV M,E ; ((HL))LB <- (E) JMP NEXT ; ********** ; * 2: * ; ********** ; DB 82H ; 2 STORE DB '2' DB '!'+80H DW CSTOR-5 TSTOR: DW $+2 POP H ; (HL) <- ADDR POP D ; (DE) <- HW MOV M,E ; (ADDR) <- HW DW BSCR-8 PORIG: DW DOCOL DW LIT DW ORIG DW PLUS DW SEMIS PAGE ; USER VARIABLES ; ; ; ********** ; * S0 * ; ********** ; DB 82H ; S0 DB 'S' DB '0'+80H DW PORIG-0AH SZERO: DW DOUSE DW 6 ; ********** ; * R0 * ; * INX H MOV M,D INX H ; (HL) <- ADDR LW POP D ; (DE) <- LW MOV M,E ; (ADDR+2) <- LW INX H MOV M,D JMP NEXT ; ********* ; * : * ; ********* ; DB 0C1H ; : DB ':'+80H DW TSTOR-5 COLON: DW DOCOL DW QEXEC DW SCSP DW CURR ********* ; DB 82H ; R0 DB 'R' DB '0'+80H DW SZERO-5 RZERO: DW DOUSE DW 8 ; *********** ; * TIB * ; *********** ; DB 83H ; TIB DB 'TI' DB 'B'+80H DW RZERO-5 TIB: DW DOUSE DB 0AH ; ************* ; * WIDTH * ; ** DW AT DW CONT DW STORE DW CREAT DW RBRAC DW PSCOD DOCOL: LHLD RPP DCX H ; (R1) <- (IP) MOV M,B DCX H ; (RP) <- (RP) - 2 MOV M,C SHLD RPP INX D ; (DE) <- CFA+2 = (W) MOV C,E ; (IP) <- (DE) = (W) MOV B,D JMP NEXT ; ******************* ; DB 85H ; WIDTH DB 'WIDT' DB 'H'+80H DW TIB-6 WIDTH: DW DOUSE DB 0CH ; *************** ; * WARNING * ; *************** ; DB 87H ; WARNING DB 'WARNIN' DB 'G'+80H DW WIDTH-8 WARN: DW DOUSE DB 0EH ; ******** ; * ; * ; ********* ; DB 0C1H ; ; DB ';'+80H DW COLON-4 SEMI: DW DOCOL DW QCSP DW COMP DW SEMIS DW SMUDG DW LBRAC DW SEMIS ; ************ ; * NOOP * ; ************ ; DB 84H ; NOOP DB 'NOO' DB 'P'+80H DW SEMI-****** ; * FENCE * ; ************* ; DB 85H ; FENCE DB 'FENC' DB 'E'+80H DW WARN-0AH FENCE: DW DOUSE DB 10H ; ********** ; * DP * ; ********** ; DB 82H ; DP DB 'D' DB 'P'+80H DW FENCE-8 DP: DW DOUSE DB 12H ; **4 NOOP: DW $+2 NOP NOP JMP NEXT ; **************** ; * CONSTANT * ; **************** ; DB 88H ; CONSTANT DB 'CONSTAN' DB 'T'+80H DW NOOP-7 CON: DW DOCOL DW CREAT DW SMUDG DW COMMA DW PSCOD DOCON: INX D ; (DE) <- PFA X************** ; * VOC-LINK * ; **************** ; DB 88H ; VOC-LINK DB 'VOC-LIN' DB 'K'+80H DW DP-5 VOCL: DW DOUSE DW 14H ; *********** ; * BLK * ; *********** ; DB 83H ; BLK DB 'BL' DB 'K'+80H DW VOCL-0BH BLK: DW DOCHG MOV E,M ; (DE) <- (PFA) INX H MOV D,M PUSH D ; (S1) <- (PFA) JMP NEXT ; **************** ; * VARIABLE * ; **************** ; DB 88H ; VARIABLE DB 'VARIABL' DB 'E'+80H DW CON-0BH VAR: DW DOCOL DW CON DW PSCOD DOVAR: IUSE DB 16H ; ********** ; * IN * ; ********** ; DB 82H ; IN DB 'I' DB 'N'+80H DW BLK-6 INN: DW DOUSE DB 18H ; *********** ; * OUT * ; *********** ; DB 83H ; OUT DB 'OU' DB 'T'+80H DW INN-5 OUTT: DW DOUSE DB 1NX D ; (DE) <- PFA PUSH D ; (S1) <- PFA JMP NEXT ; ************ ; * USER * ; ************ ; DB 84H ; USER DB 'USE' DB 'R'+80H DW VAR-0BH USER: DW DOCOL DW CON DW PSCOD DOUSE: INX D ; (DE) <- PFA XCHG MOV E,M ; (DE) <- USERAH ; *********** ; * SCR * ; *********** ; DB 83H ; SCR DB 'SC' DB 'R'+80H DW OUTT-6 SCR: DW DOUSE DB 1CH ; ************** ; * OFFSET * ; ************** ; DB 86H ; OFFSET DB 'OFFSE' DB 'T'+80H DW SCR-6 OFSET: DW  VARIABLE OFFSET MVI D,0 LHLD UP ; (HL) <- USER VARIABLE BASE ADDR DAD D ; (HL) <- (HL) + (DE) JMP HPUSH ; (S1) <- BASE + OFFSET ; ********* ; * 0 * ; ********* ; DB 81H ; 0 DB '0'+80H DW USER-7 ZERO: DW DOCON DW 0 ; *****DOUSE DB 1EH ; *************** ; * CONTEXT * ; *************** ; DB 87H ; CONTEXT DB 'CONTEX' DB 'T'+80H DW OFSET-9 CONT: DW DOUSE DB 20H ; *************** ; * CURRENT * ; *************** ; DB 87H ; CURRENT DB 'CURR/     EN' DB 'T'+80H DW CONT-0AH CURR: DW DOUSE DB 22H ; ************* ; * STATE * ; ************* ; DB 85H ; STATE DB 'STAT' DB 'E'+80H DW CURR-0AH STATE: DW DOUSE DB 24H ; ************ ; * BASE * ; ************ ; DB P * ; ************ ; DB 84H ; -DUP DB '-DU' DB 'P'+80H DW SPACE-8 DDUP: DW DOCOL DW DUP DW ZBRAN ; IF DW DDUP1-$ DW DUP ; ENDIF DDUP1: DW SEMIS ; **************** ; * TRAVERSE * ; **************** ; DB 88H ; TRAVERSE D84H ; BASE DB 'BAS' DB 'E'+80H DW STATE-8 BASE: DW DOUSE DB 26H ; DB 83H ; DPL DB 'DP' DB 'L'+80H DW BASE-7 DPL: DW DOUSE DB 28H ; *********** ; * FLD * ; *********** ; DB 83H ; FLD DB 'FL' DB 'D'+80H DW DPL-6 FLD:B 'TRAVERS' DB 'E'+80H DW DDUP-7 TRAV: DW DOCOL DW SWAP TRAV1: DW OVER ; BEGIN DW PLUS DW LIT DW 7FH DW OVER DW CAT DW LESS DW ZBRAN ; UNTIL DW TRAV1-$ DW SWAP DW DROP DW SEMIS ; ************** ; * LATEST * ; ****** DW DOUSE DB 2AH ; *********** ; * CSP * ; *********** ; DB 83H ; CSP DB 'CS' DB 'P'+80H DW FLD-6 CSPP: DW DOUSE DB 2CH ; ********** ; * R# * ; ********** ; DB 82H ; R# DB 'R' DB '#'+80H DW CSPP-6 RNUM: DW DOUS******** ; DB 86H ; LATEST DB 'LATES' DB 'T'+80H DW TRAV-0BH LATES: DW DOCOL DW CURR DW AT DW AT DW SEMIS ; *********** ; * LFA * ; *********** ; DB 83H ; LFA DB 'LF' DB 'A'+80H DW LATES-9 LFA: DW DOCOL DW LIT DW E DB 2EH ; *********** ; * HLD * ; *********** ; DB 83H ; HLD DB 'HL' DB 'D'+80H DW RNUM-5 HLD: DW DOUSE DW 30H ; ; END OF USER VARIABLES ; DB 82H ; 1+ DB '1' DB '+'+80H DW HLD-6 ONEP: DW DOCOL DW ONE DW PLUS DW S4 DW SUBB DW SEMIS ; *********** ; * CFA * ; *********** ; DB 83H ; CFA DB 'CF' DB 'A'+80H DW LFA-6 CFA: DW DOCOL DW TWO DW SUBB DW SEMIS ; *********** ; * NFA * ; *********** ; DB 83H ; NFA DB 'NF' DB 'A'+8EMIS ; ********** ; * 2+ * ; ********** ; DB 82H ; 2+ DB '2' DB '+'+80H DW ONEP-5 TWOP: DW DOCOL DW TWO DW PLUS DW SEMIS ; ************ ; * HERE * ; ************ ; DB 84H ; HERE DB 'HER' DB 'E'+80H DW TWOP-5 0H DW CFA-6 NFA: DW DOCOL DW LIT DW 5 DW SUBB DW LIT DW -1 DW TRAV DW SEMIS ; *********** ; * PFA * ; *********** ; DB 83H ; PFA DB 'PF' DB 'A'+80H DW NFA-6 PFA: DW DOCOL DW ONE DW TRAV DW LIT DW 5 DW PLUS HERE: DW DOCOL DW DP DW AT DW SEMIS ; ************* ; * ALLOT * ; ************* ; DB 85H ; ALLOT DB 'ALLO' DB 'T'+80H DW HERE-7 ALLOT: DW DOCOL DW DP DW PSTOR DW SEMIS ; ********* ; * , * ; ********* ; DB 81H DW SEMIS ; ************ ; * :CSP * ; ************ ; DB 84H ; STORE CSP DB '!CS' DB 'P'+80H DW PFA-6 SCSP: DW DOCOL DW SPAT DW CSPP DW STORE DW SEMIS ; ************** ; * ?ERROR * ; ************** ; DB 86H ; ?ERROR; , DB ','+80H DW ALLOT-8 COMMA: DW DOCOL DW HERE DW STORE DW TWO DW ALLOT DW SEMIS ; ********** ; * C, * ; ********** ; DB 82H ; C, DB 'C' DB ','+80H DW COMMA-4 CCOMM: DW DOCOL DW HERE DW CSTOR DW ONE DW ALLOT  DB '?ERRO' DB 'R'+80H DW SCSP-7 QERR: DW DOCOL DW SWAP DW ZBRAN ; IF DW QERR1-$ DW ERROR DW BRAN ; ELSE DW QERR2-$ QERR1: DW DROP ; ENDIF QERR2: DW SEMIS ; ************* ; * ?COMP * ; ************* ; DB 85H ; ?COMP DB  DW SEMIS ; ; SUBROUTINE USED BY - AND < ; ; (HL) <- (HL) - (DE) SSUB: MOV A,L ; LB SUB E MOV L,A MOV A,H ; HB SBB D MOV H,A RET ; ********* ; * - * ; ********* ; DB 81H ; - DB '-'+80H DW CCOMM-5 SUBB: DW $+2 POP D ; '?COM' DB 'P'+80H DW QERR-9 QCOMP: DW DOCOL DW STATE DW AT DW ZEQU DW LIT DW 11H DW QERR DW SEMIS ; ************* ; * ?EXEC * ; ************* ; DB 85H ; ?EXEC DB '?EXE' DB 'C'+80H DW QCOMP-8 QEXEC: DW DOCOL DW STAT(DE) <- (S1) = Y POP H ; (HL) <- (S2) = X CALL SSUB JMP HPUSH ; (S1) <- X - Y ; ********* ; * = * ; ********* ; DB 81H ; = DB '='+80H DW SUBB-4 EQUAL: DW DOCOL DW SUBB DW ZEQU DW SEMIS ; DB 81H ; < DB '<'+80H ; X < Y E DW AT DW LIT,12H DW QERR DW SEMIS ; ************** ; * ?PAIRS * ; ************** ; DB 86H ; ?PAIRS DB '?PAIR' DB 'S'+80H DW QEXEC-8 QPAIR: DW DOCOL DW SUBB DW LIT DW 13H DW QERR DW SEMIS ; ************ ; * ? DW EQUAL-4 ; S2 S1 LESS: DW $+2 POP D ; (DE) <- (S1) = Y POP H ; (HL) <- (S2) = X MOV A,D ; IF X & Y HAVE SAME SIGNS XRA H JM LES1 CALL SSUB ; (HL) <- X - Y LES1: INR H ; IF (HL) >= 0 DCR H JM LES2 LXI H,0 ; THEN X >= Y JMP HPUSCSP * ; ************ ; DB 84H ; ?CSP DB '?CS' DB 'P'+80H DW QPAIR-9 QCSP: DW DOCOL DW SPAT DW CSPP DW AT DW SUBB DW LIT DW 14H DW QERR DW SEMIS ; **************** ; * ?LOADING * ; **************** ; DB 88H ; ?LOADH ; (S1) <- FALSE LES2: LXI H,1 ; ELSE X < Y JMP HPUSH ; (S1) <- TRUE ; ********** ; * U< * ; ********** ; DB 82H ; U< ( UNSIGNED < ) DB 'U' DB '<'+80H DW LESS-4 ULESS: DW DOCOL,TDUP DW XORR,ZLESS DW ZBRAN,ULES1-$ ; IF DW DROPING DB '?LOADIN' DB 'G'+80H DW QCSP-7 QLOAD: DW DOCOL DW BLK DW AT DW ZEQU DW LIT,16H DW QERR DW SEMIS ; *************** ; * COMPILE * ; *************** ; DB 87H ; COMPILE DB 'COMPIL' DB 'E'+80H DW QLOAD-0BH COMP: DW,ZLESS DW ZEQU DW BRAN,ULES2-$ ULES1: DW SUBB,ZLESS ; ELSE ULES2: DW SEMIS ; ENDIF ; ********* ; * > * ; ********* ; DB 81H ; > DB '>'+80H DW ULESS-5 GREAT: DW DOCOL DW SWAP DW LESS DW SEMIS ; DB 83H ; ROT DB 'RO' DB  DOCOL DW QCOMP DW FROMR DW DUP DW TWOP DW TOR DW AT DW COMMA DW SEMIS ; ********* ; * [ * ; ********* ; DB 0C1H ; [ DB '['+80H DW COMP-0AH LBRAC: DW DOCOL DW ZERO DW STATE DW STORE DW SEMIS ; ********* ; * 'T'+80H DW GREAT-4 ROT: DW $+2 POP D POP H XTHL JMP DPUSH ; ************* ; * SPACE * ; ************* ; DB 85H ; SPACE DB 'SPAC' DB 'E'+80H DW ROT-6 SPACE: DW DOCOL DW BL DW EMIT DW SEMIS ; ************ ; * -DU ] * ; ********* ; DB 81H ; ] DB ']'+80H DW LBRAC-4 RBRAC: DW DOCOL DW LIT,0C0H DW STATE,STORE DW SEMIS ; ************** ; * SMUDGE * ; ************** ; DB 86H ; SMUDGE DB 'SMUDG' DB 'E'+80H DW RBRAC-4 SMUDG: DW DOCOL0      DW LATES DW LIT DW 20H DW TOGGL DW SEMIS ; *********** ; * HEX * ; *********** ; DB 83H ; HEX DB 'HE' DB 'X'+80H DW SMUDG-9 HEX: DW DOCOL DW LIT DW 10H DW BASE DW STORE DW SEMIS ; *************** ; * DECIMA DW TWO DW SUBB DW PLUS DW TOR DW ZBRAN ; IF DW EXPE6-$ DW LIT DW BELL DW BRAN ; ELSE DW EXPE7-$ EXPE6: DW LIT DW BSOUT ; ENDIF EXPE7: DW BRAN ; ELSE DW EXPE3-$ EXPE2: DW DUP DW LIT DW 0DH DW EQUAL DW ZBRAN ; IF DW EXPE4-L * ; *************** ; DB 87H ; DECIMAL DB 'DECIMA' DB 'L'+80H DW HEX-6 DEC: DW DOCOL DW LIT DW 0AH DW BASE DW STORE DW SEMIS ; *************** ; * (;CODE) * ; *************** ; DB 87H ; (;CODE) DB '(;CODE' DB ')'+$ DW LEAVE DW DROP DW BL DW ZERO DW BRAN ; ELSE DW EXPE5-$ EXPE4: DW DUP ; ENDIF EXPE5: DW IDO DW CSTOR DW ZERO DW IDO DW ONEP DW STORE ; ENDIF EXPE3: DW EMIT DW XLOOP ; LOOP DW EXPE1-$ DW DROP DW SEMIS ; *************80H DW DEC-0AH PSCOD: DW DOCOL DW FROMR DW LATES DW PFA DW CFA DW STORE DW SEMIS ; ************* ; * ;CODE * ; ************* ; DB 0C5H ; ;CODE DB ';COD' DB 'E'+80H DW PSCOD-0AH SEMIC: DW DOCOL DW QCSP DW COMP DW PS ; * QUERY * ; ************* ; DB 85H ; QUERY DB 'QUER' DB 'Y'+80H DW EXPEC-9 QUERY: DW DOCOL DW TIB DW AT DW LIT DW 50H DW EXPEC DW ZERO DW INN DW STORE DW SEMIS ; ***************** ; * 0 (NULL) * ; **********COD DW LBRAC SEMI1: DW NOOP ; ( ASSEMBLER ) DW SEMIS ; *************** ; * * ; ************* ; DB 85H ; DOES> DB 'DOES' DB '>'+80H DW BUILD-0AH DOES: DW DOCOL DW FROMR DW LATES DW PFA DW STORE DW PSCOD DODOE: LHLD RPP ; (HL) <- (RP) DCX H MOV M,B ; (R1) <- (IP) = PFA = (SUBSTITUTE CFA) DCX H F DW NULL1-$ DW ONE DW BLK DW PSTOR DW ZERO DW INN DW STORE DW BLK DW AT DW BSCR DW ONE DW SUBB DW ANDD DW ZEQU DW ZBRAN ; IF DW NULL2-$ DW QEXEC DW FROMR DW DROP ; ENDIF NULL2: DW BRAN ; ELSE DW NULL3-$ NULL1: DW MOV M,C SHLD RPP ; (RP) <- (RP) - 2 INX D ; (DE) <- PFA = (SUBSTITUTE CFA) XCHG MOV C,M ; (IP) <- (SUBSTITUTE CFA) INX H MOV B,M INX H JMP HPUSH ; (S1) <- PFA+2 = SUBSTITUTE PFA ; ************* ; * COUNT * ; ************* ; DBFROMR DW DROP ; ENDIF NULL3: DW SEMIS ; ************ ; * FILL * ; ************ ; DB 84H ; FILL DB 'FIL' DB 'L'+80H DW NULL-4 FILL: DW $+2 MOV L,C MOV H,B POP D POP B XTHL XCHG FILL1: MOV A,B ; BEGIN ORA C JZ FILL2 ; 85H ; COUNT DB 'COUN' DB 'T'+80H DW DOES-8 COUNT: DW DOCOL DW DUP DW ONEP DW SWAP DW CAT DW SEMIS PAGE ; ************ ; * TYPE * ; ************ ; DB 84H ; TYPE DB 'TYP' DB 'E'+80H DW COUNT-8 TYPE: DW DOCOL DW DDUP WHILE MOV A,L STAX D INX D DCX B JMP FILL1 ; REPEAT FILL2: POP B JMP NEXT ; ************* ; * ERASE * ; ************* ; DB 85H ; ERASE DB 'ERAS' DB 'E'+80H DW FILL-7 ERASEE: DW DOCOL DW ZERO DW FILL DW SEMIS ;  DW ZBRAN ; IF DW TYPE1-$ DW OVER DW PLUS DW SWAP DW XDO ; DO TYPE2: DW IDO DW CAT DW EMIT DW XLOOP ; LOOP DW TYPE2-$ DW BRAN ; ELSE DW TYPE3-$ TYPE1: DW DROP ; ENDIF TYPE3: DW SEMIS PAGE ; ***************** ; * -TRAILING************** ; * BLANKS * ; ************** ; DB 86H ; BLANKS DB 'BLANK' DB 'S'+80H DW ERASEE-8 BLANK: DW DOCOL DW BL DW FILL DW SEMIS ; ************ ; * HOLD * ; ************ ; DB 84H ; HOLD DB 'HOL' DB 'D'+80H D * ; ***************** ; DB 89H ; -TRAILING DB '-TRAILIN' DB 'G'+80H DW TYPE-7 DTRAI: DW DOCOL DW DUP DW ZERO DW XDO ; DO DTRA1: DW OVER DW OVER DW PLUS DW ONE DW SUBB DW CAT DW BL DW SUBB DW ZBRAN ; IF DW DTRA2-$ DWW BLANK-9 HOLD: DW DOCOL DW LIT DW -1 DW HLD DW PSTOR DW HLD DW AT DW CSTOR DW SEMIS ; *********** ; * PAD * ; *********** ; DB 83H ; PAD DB 'PA' DB 'D'+80H DW HOLD-7 PAD: DW DOCOL DW HERE DW LIT DW 44H DW PLUS LEAVE DW BRAN ; ELSE DW DTRA3-$ DTRA2: DW ONE DW SUBB ; ENDIF DTRA3: DW XLOOP ; LOOP DW DTRA1-$ DW SEMIS ; ************ ; * (.") * ; ************ ; DB 84H ; (.") DB '(."' DB ')'+80H DW DTRAI-0CH PDOTQ: DW DOCOL DW RR D DW SEMIS ; ************* ; * FPTR * ; ************* ; DB 84H ; FPTR ; ( FILE POINTER OF TLOAD ) DB 'FPT' DB 'R'+80H DW PAD-6 FPTR: DW DOVAR DW 0 ; ************** ; * ?TLOAD * ; ************** DB 86H ; ?TLOAD ; W COUNT DW DUP DW ONEP DW FROMR DW PLUS DW TOR DW TYPE DW SEMIS ; ********* ; * . * ; ********* ; DB 0C2H ; ." DB '.' DB '"'+80H DW PDOTQ-7 DOTQ: DW DOCOL DW LIT DW 22H DW STATE DW AT DW ZBRAN ; IF DW DOTQ1-$ ( ARE WE TLOADING? ) DB '?TLOA' DB 'D'+80H DW FPTR-7 QTLOAD: DW DOVAR DW 0 ; ; ; ************** ; * DBUFF1 * ; ************** DB 86H ; DBUFF1 ; ( DATA BUFFER #1 ) DB 'DBUFF' DB '1'+80H DW QTLOAD-9 DBUFF1: DW DOCON DW 29178 DW COMP DW PDOTQ DW WORD DW HERE DW CAT DW ONEP DW ALLOT DW BRAN ; ELSE DW DOTQ2-$ DOTQ1: DW WORD DW HERE DW COUNT DW TYPE ; ENDIF DOTQ2: DW SEMIS ; ************** ; * EXPECT * ; ************** ; DB 86H ; EXPECT DB ; ; ************** ; * DBUFF2 * ; ************** DB 86H ; DBUFF2 ; ( DATA BUFFER #2 ) DB 'DBUFF' DB '2'+80H DW DBUFF1-9 DBUFF2: DW DOCON DW 30206 ; ; ************ ; * WORD * ; ************ ; DB 84H ; WORD--MODIFIED FO 'EXPEC' DB 'T'+80H DW DOTQ-5 EXPEC: DW DOCOL DW OVER DW PLUS DW OVER DW XDO ; DO EXPE1: DW KEY DW DUP DW LIT DW 0EH DW PORIG DW AT DW EQUAL DW ZBRAN ; IF DW EXPE2-$ DW DROP DW DUP DW IDO DW EQUAL DW DUP DW FROMR R FORTH COMP BY NAA DB 'WOR' DB 'D'+80H DW DBUFF2-9 WORD: DW DOCOL DW QTLOAD DW AT DW ZEQU DW ZBRAN ; IF DW WORD4-$ ; DW BLK ; FOR FORTH COMP, ASSUME ONLY BLOCK 0 ; DW AT ; DW ZBRAN ; IF ; DW WORD1-$ ; DW BLK ; DW AT ; DW BLOCK ; 1     DW BRAN ; ELSE ; DW WORD2-$ WORD1: DW TIB DW AT ; ENDIF WORD3: DW BRAN ; ELSE DW WORD2-$ WORD4: DW DBUFF2 ; BUFFER 2, COMPILE RAM WORD2: DW INN DW AT DW PLUS DW SWAP DW ENCL DW HERE DW LIT DW 22H DW BLANK DW INN DW PSTOR DW ODW CAT DW BL,SUBB DW ZBRAN DW SPNUM1-$ DW WARNU SPNUM1: DW FROMR DW ZBRAN DW SPNUM2-$ DW MINUS SPNUM2: DW SEMIS ; ***************** ; * TINTERPRET * ; ***************** ; DB 8AH ; FOR TLOADING DB 'TINTERPRE' DB 'T'+80H VER DW SUBB DW TOR DW RR DW HERE DW CSTOR DW PLUS DW HERE DW ONEP DW FROMR DW CMOVE DW SEMIS ; ************ ; * MON * ; ************ ; DB 83H ; MON--RETURN TO DEBUG MONITOR DB 'MO' DB 'N'+80H DW WORD-7 MON: DW $+2  DW SPNUMB-12 TINTER: DW DOCOL TINTE1: DW SPFIND ; BEGIN DW ZBRAN ; IF DW TINTE2-$ DW STATE DW NOOP DW AT DW LESS DW ZBRAN ; IF DW TINTE3-$ DW CFA DW COMMA DW BRAN ; ELSE DW TINTE4-$ TINTE3: DW CFA DW EXEC ; ENDIF TINTE4: DW ; CODE DEFINITION JMP 38H JMP NEXT ; **************** ; * WARN * ; **************** ; DB 84H ; ISSUE WARNING OF UNDEFINED WORD DB 'WAR' DB 'N'+80H DW MON-6 WARNU: DW DOCOL DW CR DW HERE DW COUNT DW TYPE DW PDOTQ DB QSTAC DW BRAN ; ELSE DW TINTE5-$ TINTE2: DW HERE DW SPNUMB DW LITER TINTE7: DW QSTAC ; ENDIF TINTE5: DW BRAN ; AGAIN--NOTE: 'X' = NULL WORD EXITS LOOP DW TINTE1-$ ; ***************** ; * SCAN/AHEAD * ; ***************** ; DB 8AH 33,' ? NOT DEFINED -- CONTINUING... ' DW DROP,ZERO DW SEMIS ; ; ; **************** ; * WHERE * ; **************** ; DB 85H ; WHERE, PRINT COMPILIATION DB 'WHER' DB 'E'+80H DW WARNU-7 ; WHERE: DW DOCOL DW HERE DW ONEP DW CA ; PREPARE FOR COMPILE DB 'SCAN/AHEA' DB 'D'+80H DW TINTER-13 SCAN: DW DOCOL DW DBUFF2 DW LIT,600 DW OVER,PLUS DW SWAP DW XDO SCAN1: DW IDO,CAT DW LIT,127 DW ANDD DW DUP DW BL,LESS DW ZBRAN DW SCAN2-$ DW DROP DW BL ; INSET DW LIT DW 58 ; COLON DW EQUAL DW ZBRAN DW WHERE1-$ DW CR DW PDOTQ DB 14,'COMPILING --> ' DW DBUFF2 DW INN,AT DW PLUS DW LIT DW 32 DW ENCL DW DROP,SWAP DW DROP,TYPE DW SPACE WHERE1: DW SEMIS ; ; ; **************** ; RT BLANK SCAN2: DW IDO,CSTOR DW XLOOP DW SCAN1-$ DW DBUFF2 DW LIT,600 DW PLUS DW LIT,80 DW OVER,PLUS DW SWAP DW XDO SCAN4: DW IDO DW CAT DW LIT,127 DW ANDD DW DUP DW LIT,20 DW LESS DW ZBRAN DW SCAN5-$ DW DROP DW ZERO* SP.FIND * ; **************** ; DB 87H ; SPECIAL FIND, FOR TLOAD DB 'SP.FIN' DB 'D'+80H DW WHERE-8 ; SPFIND: DW DOCOL DW BL DW WORD DW WHERE DW HERE,CONT DW AT,AT DW PFIND DW DUP DW ZEQU DW ZBRAN ; IF DW SPFIN1-$ DW ,ZERO DW IDO ; INSERT END COMPILATION DW ONEP,CSTOR DW IDO DW DBUFF2 DW SUBB DW FPTR,PSTOR DW LEAVE SCAN5: DW IDO DW CSTOR DW XLOOP,SCAN4-$ DW SEMIS ; ***************** ; * NXT.BLK * ; ***************** ; DB 87H ; DROP DW HERE DW LATES DW PFIND ; ENDIF SPFIN1: DW SEMIS ; ; **************** ; * (NUMBER) * ; **************** ; DB 88H ; (NUMBER) DB '(NUMBER' DB ')'+80H DW SPFIND-10 PNUMB: DW DOCOL PNUM1: DW ONEP ; BEGIN DW DUP DW TOR DW FETCH NEXT DISK BLOCK DB 'NXT.BL' DB 'K'+80H DW SCAN-13 NXTBLK: DW DOCOL DW QTLOAD,AT DW ZBRAN DW NXTBL1-$ DW FPTR,AT ; WE ARE TLOADING DW LIT,768 DW VMTRAM DW SCAN DW ZERO DW INN,STORE DW BRAN DW NXTBL2-$ NXTBL1: DW ONE DWCAT DW BASE DW AT DW DIGIT DW ZBRAN ; WHILE DW PNUM2-$ DW SWAP DW BASE DW AT DW USTAR DW DROP DW ROT DW BASE DW AT DW USTAR DW DPLUS DW DPL DW AT DW ONEP DW ZBRAN ; IF DW PNUM3-$ DW ONE DW DPL DW PSTOR ; ENDIF  BLK,PSTOR NXTBL2: DW SEMIS ; ***************** ; * TLOAD * ; ***************** ; DB 85H ; BEGIN SPECIAL INTERPRET DB 'TLOA' DB 'D'+80H DW NXTBLK-10 TLOAD: DW DOCOL DW LIT,-1 DW WARN,STORE DW KEYTO DW POPEN DW ZERO DW  PNUM3: DW FROMR DW BRAN ; REPEAT DW PNUM1-$ PNUM2: DW FROMR DW SEMIS ; ************** ; * NUMBER * ; ************** ; DB 86H ; NUMBER DB 'NUMBE' DB 'R'+80H DW PNUMB-0BH NUMB: DW DOCOL DW ZERO DW ZERO DW ROT DW DUP DW FPTR,STORE DW INN,AT DW TOR DW ZERO DW INN,STORE DW ONE,QTLOAD DW STORE DW NXTBLK DW TINTER DW FROMR DW INN,STORE DW CR DW PDOTQ DB 20,'END TEXT COMPILATION' DW CR DW FCB DW ONEP DW LIT,35 DW ZERO,FILL DW ZERO,QTLOAD ONEP DW CAT DW LIT DW 2DH DW EQUAL DW DUP DW TOR DW PLUS DW LIT DW -1 NUMB1: DW DPL ; BEGIN DW STORE DW PNUMB DW DUP DW CAT DW BL DW SUBB DW ZBRAN ; WHILE DW NUMB2-$ DW DUP DW CAT DW LIT DW 2EH DW SUBB DW ZERO DW STORE DW ONE,WARN DW STORE DW SEMIS ; *************** ; * (ABORT) * ; *************** ; DB 87H ; (ABORT) DB '(ABORT' DB ')'+80H DW TLOAD-8 PABOR: DW DOCOL ; USER ABORT DW ZERO,QTLOAD DW STORE DW CR DW PDOTQ DB 17 DW QERR DW ZERO DW BRAN ; REPEAT DW NUMB1-$ NUMB2: DW DROP DW FROMR DW ZBRAN ; IF DW NUMB3-$ DW DMINU ; ENDIF NUMB3: DW SEMIS ; ************* ; * -FIND * ; ************* ; DB 85H ; -FIND (0-3) SUCCESS DB '-FIN' ; (0-1) FA,'ABORTING COMPILE ' DW ONE,WARN DW STORE DW ERROR DW SEMIS ; ************* ; * ERROR * ; ************* ; DB 85H ; ERROR DB 'ERRO' DB 'R'+80H DW PABOR-0AH ERROR: DW DOCOL DW WARN DW AT DW ZLESS DW ZBRAN ; IF DW ERRO1-ILURE DB 'D'+80H DW NUMB-9 DFIND: DW DOCOL DW BL DW WORD DW HERE DW CONT DW AT DW AT DW PFIND DW DUP DW ZEQU DW ZBRAN ; IF DW DFIN1-$ DW DROP DW HERE DW LATES DW PFIND ; ENDIF DFIN1: DW SEMIS ; **************** ; * $ DW PABOR ; ENDIF ERRO1: DW HERE DW COUNT DW TYPE DW PDOTQ DB 2 DB '? ' DW MESS DW SPSTO ERRO2: DW QUIT ; *********** ; * ID. * ; *********** ; DB 83H DB 'ID' DB '.'+80H DW ERROR-8 IDDOT: DW DOCOL DW PAD DW LIT  SP.NUMBER * ; **************** ; DB 89H ; SPECIAL NUMBER PROCESS, FOR TLOAD DB 'SP.NUMBE' DB 'R'+80H DW DFIND-8 ; SPNUMB: DW DOCOL DW ZERO,ZERO DW ROT,DUP DW ONEP,CAT DW LIT,45 DW EQUAL DW DUP,TOR DW PLUS,PNUMB DW SWAP,DROP  DW 20H DW LIT DW 5FH DW FILL DW DUP DW PFA DW LFA DW OVER DW SUBB DW PAD DW SWAP DW CMOVE DW PAD DW COUNT DW LIT DW 1FH DW ANDD DW TYPE DW SPACE DW SEMIS ; ************** ; * CREATE * ; ************** ; 2     DB 86H DB 'CREAT' DB 'E'+80H DW IDDOT-6 CREAT: DW DOCOL DW DFIND DW ZBRAN ; IF DW CREA1-$ DW DROP DW NFA DW IDDOT DW LIT,4 DW MESS DW SPACE ; ENDIF CREA1: DW HERE DW DUP DW CAT DW WIDTH DW AT DW MIN DW ONEP DW ALLOT  DW STORE DW LBRAC QUIT1: DW RPSTO ; BEGIN DW CR DW QUERY DW INTER DW STATE DW AT DW ZEQU DW ZBRAN ; IF DW QUIT2-$ DW PDOTQ DB 2 DB 'OK' ; ENDIF QUIT2: DW BRAN ; AGAIN DW QUIT1-$ ; ************* ; * ABORT * ; ****** DW DUP DW LIT,0A0H DW TOGGL DW HERE DW ONE DW SUBB DW LIT,80H DW TOGGL DW LATES DW COMMA DW CURR DW AT DW STORE DW HERE DW TWOP DW COMMA DW SEMIS ; ***************** ; * [COMPILE] * ; ***************** ; DB 0C9******* ; DB 85H DB 'ABOR' DB 'T'+80H DW QUIT-7 ABORT: DW DOCOL DW SPSTO DW DEC DW QSTAC DW CR DW PDOTQ DB 0DH DB 'fig-FORTH ' DB FIGREL+30H,ADOT,FIGREV+30H DW FORTH DW DEFIN DW QUIT PAGE ; WARM START ENTRY POINT ; WRH DB '[COMPILE' DB ']'+80H DW CREAT-9 BCOMP: DW DOCOL DW DFIND DW ZEQU DW ZERO DW QERR DW DROP DW CFA DW COMMA DW SEMIS ; *************** ; * LITERAL * ; *************** ; DB 0C7H DB 'LITERA' DB 'L'+80H DW BCOMP-0M: LXI B,WRM1 JMP NEXT WRM1: DW WARM ; ************ ; * WARM * ; ************ ; DB 84H DB 'WAR' DB 'M'+80H DW ABORT-8 WARM: DW DOCOL DW ABORT ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; COLD START ENTRY POINT ; ; (EVERYTHCH LITER: DW DOCOL DW STATE DW AT DW ZBRAN ; IF DW LITE1-$ DW COMP DW LIT DW COMMA ; ENDIF LITE1: DW SEMIS ; **************** ; * DLITERAL * ; **************** ; DB 0C8H DB 'DLITERA' DB 'L'+80H DW LITER-0AH DLITE: DW DOING IS RESET) ; CLD: LXI B,CLD1 LHLD ORIG+12H SPHL JMP NEXT CLD1: DW COLD ; ************ ; * COLD * ; ************ ; DB 84H DB 'COL' DB 'D'+80H DW WARM-7 COLD: DW DOCOL ; DW FIRST ; NOT USED IN FORTH COMP ; DW USE,STORE ; COL DW STATE DW AT DW ZBRAN ; IF DW DLIT1-$ DW SWAP DW LITER DW LITER ; ENDIF DLIT1: DW SEMIS ; ************** ; * ?STACK * ; ************** ; DB 86H DB '?STAC' DB 'K'+80H DW DLITE-0BH QSTAC: DW DOCOL DW SPAT DW SZERDW FIRST ; DW PREV,STORE ; DW DRZER DW LIT,0 DW LIT,EPRINT DW STORE DW LIT,ORIG+12H DW LIT,UP DW AT DW LIT,6 DW PLUS DW LIT,16 DW CMOVE DW LIT,ORIG+0CH DW AT DW LIT,FORTH+6 DW STORE DW ABORT PAGE ; ************ ; * SO DW AT DW SWAP DW ULESS DW ONE DW QERR DW SPAT DW HERE DW LIT DW 80H DW PLUS DW ULESS DW LIT DW 7 DW QERR DW SEMIS ; ***************** ; * INTERPRET * ; ***************** ; DB 89H DB 'INTERPRE' DB 'T'+80H ->D * ; ************ ; DB 84H DB 'S->' DB 'D'+80H DW COLD-7 STOD: DW $+2 POP D LXI H,0 MOV A,D ANI 80H JZ STOD1 DCX H STOD1: JMP DPUSH ; ********** ; * +- * ; ********** ; DB 82H DB '+' DB '-'+80H DW STOD-7 PMDW QSTAC-9 INTER: DW DOCOL INTE1: DW DFIND ; BEGIN DW ZBRAN ; IF DW INTE2-$ DW STATE DW AT DW LESS DW ZBRAN ; IF DW INTE3-$ DW CFA DW COMMA DW BRAN ; ELSE DW INTE4-$ INTE3: DW CFA DW EXEC ; ENDIF INTE4: DW QSTAC DW BRAN ; ELSE: DW DOCOL DW ZLESS DW ZBRAN ; IF DW PM1-$ DW MINUS ; ENDIF PM1: DW SEMIS ; *********** ; * D+- * ; *********** ; DB 83H DB 'D+' DB '-'+80H DW PM-5 DPM: DW DOCOL DW ZLESS DW ZBRAN ; IF DW DPM1-$ DW DMINU ; ENDIF DPM1: DW INTE5-$ INTE2: DW HERE DW NUMB DW DPL DW AT DW ONEP DW ZBRAN ; IF DW INTE6-$ DW DLITE DW BRAN ; ELSE DW INTE7-$ INTE6: DW DROP DW LITER ; ENDIF INTE7: DW QSTAC ; ENDIF INTE5: DW BRAN ; AGAIN DW INTE1-$ ; *************** DW SEMIS ; *********** ; * ABS * ; *********** ; DB 83H DB 'AB' DB 'S'+80H DW DPM-6 ABS: DW DOCOL DW DUP DW PM DW SEMIS ; ************ ; * DABS * ; ************ ; DB 84H DB 'DAB' DB 'S'+80H DW ABS-6 DABS: DW** ; * IMMEDIATE * ; ***************** ; DB 89H DB 'IMMEDIAT' DB 'E'+80H DW INTER-0CH IMMED: DW DOCOL DW LATES DW LIT DW 40H DW TOGGL DW SEMIS ; ****************** ; * VOCABULARY * ; ****************** ; DB 8AH DB  DOCOL DW DUP DW DPM DW SEMIS ; *********** ; * MIN * ; *********** ; DB 83H DB 'MI' DB 'N'+80H DW DABS-7 MIN: DW DOCOL,TDUP DW GREAT DW ZBRAN ; IF DW MIN1-$ DW SWAP ; ENDIF MIN1: DW DROP DW SEMIS ; *********** ;'VOCABULAR' DB 'Y'+80H DW IMMED-0CH VOCAB: DW DOCOL DW BUILD DW LIT DW 0A081H DW COMMA DW CURR DW AT DW CFA DW COMMA DW HERE DW VOCL DW AT DW COMMA DW VOCL DW STORE DW DOES DOVOC: DW TWOP DW CONT DW STORE DW SEMIS  * MAX * ; *********** ; DB 83H DB 'MA' DB 'X'+80H DW MIN-6 MAX: DW DOCOL,TDUP DW LESS DW ZBRAN ; IF DW MAX1-$ DW SWAP ; ENDIF MAX1: DW DROP DW SEMIS ; ********** ; * M* * ; ********** ; DB 82H DB 'M' DB '*'+80H  ; ************* ; * FORTH * ; ************* ; DB 0C5H DB 'FORT' DB 'H'+80H DW VOCAB-0DH FORTH: DW DODOE DW DOVOC DW 0A081H DW TASK-7 ; COLD START VALUE ONLY ; CHANGED EACH TIME A DEF IS APPENDED ; TO THE FORTH VOCABULAR DW MAX-6 MSTAR: DW DOCOL,TDUP DW XORR DW TOR DW ABS DW SWAP DW ABS DW USTAR DW FROMR DW DPM DW SEMIS ; ********** ; * M/ * ; ********** ; DB 82H DB 'M' DB '/'+80H DW MSTAR-5 MSLAS: DW DOCOL DW OVER DW TOR DW Y DW 0 ; END OF VOCABULARY LIST ; ******************* ; * DEFINITIONS * ; ******************* ; DB 8BH DB 'DEFINITION' DB 'S'+80H DW FORTH-8 DEFIN: DW DOCOL DW CONT DW AT DW CURR DW STORE DW SEMIS ; ********* ; * ( TOR DW DABS DW RR DW ABS DW USLAS DW FROMR DW RR DW XORR DW PM DW SWAP DW FROMR DW PM DW SWAP DW SEMIS ; ********* ; * * * ; ********* ; DB 81H DB '*'+80H DW MSLAS-5 STAR: DW DOCOL DW MSTAR DW DROP DW SEMI * ; ********* ; DB 0C1H DB '('+80H DW DEFIN-0EH PAREN: DW DOCOL DW LIT DW 29H DW WORD DW SEMIS ; ************ ; * QUIT * ; ************ ; DB 84H ; QUIT DB 'QUI' DB 'T'+80H DW PAREN-4 QUIT: DW DOCOL DW ZERO DW BLKS ; ************ ; * /MOD * ; ************ ; DB 84H DB '/MO' DB 'D'+80H DW STAR-4 SLMOD: DW DOCOL DW TOR DW STOD DW FROMR DW MSLAS DW SEMIS ; ********* ; * / * ; ********* ; DB 81H DB '/'+80H DW SLMOD-7 SLA3     SH: DW DOCOL DW SLMOD DW SWAP DW DROP DW SEMIS ; *********** ; * MOD * ; *********** ; DB 83H DB 'MO' DB 'D'+80H DW SLASH-4 MODD: DW DOCOL DW SLMOD DW DROP DW SEMIS ; ************* ; * */MOD * ; *************  DW FCBFN DW HERE DW CAT DW LIT DW 8 DW MIN DW CMOVE ; WRITE NEW NAME DW SEMIS ; ************** ; * >EXT * ; ************** ; DB 84H DB '>EX' DB 'T'+80H DW TFNAME-9 TOEXT: DW DOCOL ; HERE TO FILE EXTENSION DW FCBFN; DB 85H DB '*/MO' DB 'D'+80H DW MODD-6 SSMOD: DW DOCOL DW TOR DW MSTAR DW FROMR DW MSLAS DW SEMIS ; ********** ; * */ * ; ********** ; DB 82H DB '*' DB '/'+80H DW SSMOD-8 SSLA: DW DOCOL DW SSMOD DW SWAP DW DRO DW LIT DW 8 DW PLUS DW LIT DW 3 DW BL DW FILL ; BLANK OLD EXTENSION DW HERE DW ONEP DW FCBFN DW LIT DW 8 DW PLUS DW HERE DW CAT DW LIT DW 3 DW MIN DW CMOVE ; WRITE NEW EXTENSION DW SEMIS ; *************** ; * P DW SEMIS ; ************* ; * M/MOD * ; ************* ; DB 85H DB 'M/MO' DB 'D'+80H DW SSLA-5 MSMOD: DW DOCOL DW TOR DW ZERO DW RR DW USLAS DW FROMR DW SWAP DW TOR DW USLAS DW FROMR DW SEMIS PAGE ;********** KEY>FNAME * ; *************** ; DB 89H DB 'KEY>FNAM' DB 'E'+80H DW TOEXT-7 KEYTO: DW DOCOL ; INPUT FNAME FROM KEYBOARD DW CR DW PDOTQ DB 25,'ENTER "FILENAME.EXT" --> ' DW QUERY DW TIB,AT DW ONEP,CAT DW LIT DW 58 DW EQUAL ************************************** ; * ; CP/M INTERFACE * ; * ;************************************************ ; BDOS CONSTANTS FCBK EQU 5CH BDOSK EQU 5 DB 84H ; BDOS ; ( CP/M DOS ENTRY POINT ) DB 'BDO' DB 'S'+80DW ZBRAN DW KEYTO1-$ DW TWO DW INN DW PSTOR DW TIB,AT DW CAT DW LIT DW 66 DW SUBB DW ZBRAN DW KEYTO2-$ DW DRA DW BRAN DW KEYTO1-$ KEYTO2: DW DRB ; ELSE KEYTO1: DW LIT DW 46 DW WORD DW HERE DW ONEP DW CAT DW ZEQU H DW MSMOD-8 BDOSS: DW DOCON DW 5 DB 86H ; OPENFC ; ( OPEN FILE CONSTANT ) DB 'OPENF' DB 'C'+80H DW BDOSS-7 OPENFC: DW DOCON DW 0FH DB 86H ; MAKEFC ; ( MAKE FILE CONSTANT ) DB 'MAKEF' DB 'C'+80H DW OPENFC-9 MAKEFC: DW DOC DW ZBRAN DW KEYTO3-$ DW QUIT ; NULL ENTRY KEYTO3: DW TFNAME DW BL,WORD DW HERE,ONEP DW CAT DW ZBRAN DW KEYTO4-$ DW TOEXT KEYTO4: DW SEMIS ; *************** ; * .NOFILE * ; *************** ; DB 87H DB '.NOFIL' DB 'E'+80H ON DW 16H DB 86H ; READFC ; ( READ FILE CONSTANT ) DB 'READF' DB 'C'+80H DW MAKEFC-9 READFC: DW DOCON DW 14H DB 83H ; FCB ; ( FILE CONTROL BLOCK ) DB 'FC' DB 'B'+80H DW READFC-9 FCB: DW DOCON DW 5CH DB 84H ; BUFF ;  DW KEYTO-12 PNOFIL: DW DOCOL ; PRINT NO FILE DW CR DW PDOTQ DB 17,'CANNOT FIND FILE ' DW FCBFN DW LIT DW 8 DW TYPE DW PDOTQ DB 1,'.' DW FCBFN DW LIT DW 8 DW PLUS DW LIT DW 3 DW TYPE DW QUIT DW SEMIS ; ************( DEFAULT BUFFER ADDRESS ) DB 'BUF' DB 'F'+80H DW FCB-6 BUFF: DW DOCON DW 80H DB 85H ; FCBDN ; ( DISK NAME ) DB 'FCBD' DB 'N'+80H DW BUFF-7 FCBDN: DW DOCON DW FCBK+0 DB 85H ; FCBFN ; ( FILE NAME ) DB 'FCBF' DB 'N'+80H *** ; * *OPEN * ; *************** ; DB 85H DB '*OPE' DB 'N'+80H DW PNOFIL-10 SOPEN: DW $+2 ; OPEN A FILE PUSH B ; SAVE INTERPRETIVE POINTER MVI C,15 JMP BDOSC ; FINISH DOS COMMAND ; *************** ; * (OPEN) * ; **** DW FCBDN-8 FCBFN: DW DOCON DW FCBK+1 DB 85H ; FCBFT ; ( FILE TYPE ) DB 'FCBF' DB 'T'+80H DW FCBFN-8 FCBFT: DW DOCON DW FCBK+9 DB 85H ; FCBRL ; ( FILES CURRENT REEL ) DB 'FCBR' DB 'L'+80H DW FCBFT-8 FCBRL: DW DOCON DW FC*********** ; DB 86H DB '(OPEN' DB ')'+80H DW SOPEN-8 POPEN: DW DOCOL ; OPEN THE FILE IN FNAME DW FCB DW LIT DW 12 DW PLUS DW LIT DW 24 DW ZERO DW FILL DW SOPEN ; PRIMITIVE DW LIT DW 255 DW EQUAL DW ZBRAN DW POPEN1-BK+12 DB 85H ; FCBRC ; ( FILES RECORD COUNT ) DB 'FCBR' DB 'C'+80H DW FCBRL-8 FCBRC: DW DOCON DW FCBK+15 DB 85H ; C.REC ; ( CURRENT RECORD ) DB 'C.RE' DB 'C'+80H DW FCBRC-8 CREC: DW DOCON DW FCBK+32 DB 85H ; R.REC ; ($ DW PNOFIL ; CANNOT FIND FILE POPEN1: DW SEMIS ; *************** ; * OPEN * ; *************** ; DB 84H DB 'OPE' DB 'N'+80H DW POPEN-9 OPEN: DW DOCOL ; ASK AND OPEN THE FILE DW KEYTO DW POPEN DW ZERO DW CREC DW CSTOR  RANDOM RECORD # ) DB 'R.RE' DB 'C'+80H DW CREC-8 RREC: DW DOCON DW FCBK+33 ; IMPORTANT ENTRY FOR CP/M BDOSC: LXI D,FCBK ; FILE CONTROL BLOCK IN DE CALL BDOSK MVI D,0 MOV E,A POP B PUSH D ; ERROR CODE TO STACK JMP NEXT ; BA DW SEMIS ; *************** ; * *SETDMA * ; *************** ; DB 87H DB '*SETDM' DB 'A'+80H DW OPEN-7 SDMA: DW $+2 ; SET DMA POP D ; TAKE STACK ENTRY PUSH B ; SAVE INTERPRETIVE POINTER MVI C,26 CALL BDOSK ; CALL CP/M CK TO FORTH ; ************** ; * BDOSCMD * ; ************** ; DB 87H DB 'BDOSCM' DB 'D'+80H ; BDOS COMMAND CONSTANT ENTRY DW RREC-8 BDOSCMD: DW DOCON DW BDOSC ; ************** ; * DRA * ; ************** ; DB 83H DB 'POP B JMP NEXT ; *************** ; * *RREAD * ; *************** ; DB 86H DB '*RREA' DB 'D'+80H DW SDMA-10 SRREAD: DW $+2 ; RANDOM READ OF FILE PUSH B ; SAVE INTERPRETIVE POINTER MVI C,33 JMP BDOSC ; FINISH CP/M COMMAND DR' DB 'A'+80H ; SET DRIVE 'A' DW BDOSCMD-10 DRA: DW DOCOL DW ONE DW FCB DW CSTOR DW SEMIS ; ************** ; * DRB * ; ************** ; DB 83H DB 'DR' DB 'B'+80H ; SET DRIVE 'B' DW DRA-6 DRB: DW DOCOL DW TWO DW F ; *************** ; * RREAD * ; *************** ; DB 85H DB 'RREA' DB 'D'+80H DW SRREAD-9 RREAD: DW DOCOL ; RANDOM READ OF FILE DW ZERO DW RREC DW TWO DW PLUS DW CSTOR DW RREC DW STORE DW SRREAD DW LIT DW 25 DWCB DW CSTOR DW SEMIS ; ************** ; * >FNAME * ; ************** ; DB 86H DB '>FNAM' DB 'E'+80H DW DRB-6 TFNAME: DW DOCOL ; HERE TO FILE NAME DW FCBFN DW LIT DW 11 DW BL DW FILL ; BLANK OLD NAME DW HERE DW ONEP  QERR DW SEMIS DB 83H ; POINTER DB 'PT' DB 'R'+80H DW RREAD-8 PTRV: DW DOVAR DW 0 ; *************** ; * 8IN * ; *************** ; DB 83H DB '8I' DB 'N'+80H DW PTRV-6 EIN: DW DOCOL ; READ IN 8 BLOCKS RANDOMLY DW4      ZERO DW PTRV DW STORE DW LIT DW 8 DW ZERO DW XDO EIN2: DW DBUFF1 DW PTRV DW AT DW PLUS DW SDMA DW SRREAD DW ONE DW RREC DW PSTOR DW ZBRAN DW EIN1-$ DW LEAVE EIN1: DW LIT DW 128 DW PTRV DW PSTOR DW XLOOP,EIN2-$  CALL IOS ; (A) <- CHR, (MSB) <- 0 POP B RET ; COUT: PUSH H ; CONSOLE OUTPUT LXI D,KCOUT ; WAIT UNTIL READY CALL IOS ; THEN OUTPUT (C) POP H RET ; POUT: LXI D,KPOUT ; PRINTER OUTPUT CALL IOS ; WAIT UNTIL READY RET ; THEN OUTPUT (C)  DW BUFF DW SDMA DW SEMIS DB 86H ; VARIABLE 'FROM.D' DB 'FROM.' DB 'D'+80H DW EIN-6 FROMD: DW DOVAR DW 0 DB 82H ; VARIABLE 'CT' DB 'C' DB 'T'+80H DW FROMD-9 CT: DW DOVAR DW 0 ; ****************** ; * VM>RAM * ;; CPOUT: PUSH B CALL COUT ; OUTPUT (C) TO CONSOLE POP B XCHG LXI H,EPRINT MOV A,M ; IF (EPRINT) <> 0 ORA A JZ CPOU1 CALL POUT CPOU1: RET ; ; FORTH TO CP/M SERIAL IO INTERFACE ; PQTER: CALL CSTAT ; IF CHR TYPED LXI H,0 ORA A JZ P ****************** ; DB 86H DB 'VM>RA' DB 'M'+80H DW CT-5 VMTRAM: DW DOCOL ; FROM DISK TO BUFFER DW CT DW STORE DW FROMD,STORE DW FROMD,AT DW ZERO DW LIT,128 DW USLAS DW SWAP DW DROP DW RREC DW STORE DW EIN ; READ INTO QTE1 INR L ; THEN (S1) <- TRUE PQTE1: JMP HPUSH ; ELSE (S1) <- FALSE ; PKEY: CALL CIN ; READ CHR FROM CONSOLE CPI DLE ; IF CHR = (^P) MOV E,A JNZ PKEY1 LXI H,EPRINT ; THEN TOGGLE (EPRINT)LSB MVI E,ABL ; CHR <- BLANK MOV A,M XRI 1 MOV BUFFER DW DBUFF1 DW FROMD,AT DW ZERO DW LIT,128 DW USLAS DW DROP DW PLUS DW DBUFF2 DW CT,AT DW CMOVE DW SEMIS ; *************** ; * MESSAGE * ; * NEW * ; *************** ; ERRSTR: DB 'ERROR TXT' ; ERROR.TXT IS FM,A PKEY1: MOV L,E MVI H,0 JMP HPUSH ; (S1)LB <- CHR ; PEMIT: DW $+2 ; (EMIT) ORPHAN POP H ; (L) <- (S1)LB = CHR PUSH B ; SAVE (IP) MOV C,L CALL CPOUT ; OUTPUT CHR TO CONSOLE ; ; & MAYBE PRINTER POP B ; RESTORE (IP) JMP NEXT ; PCR: ILE NAME DB 87H DB 'MESSAG' DB 'E'+80H DW VMTRAM-9 MESS: DW DOCOL DW WARN DW AT DW ZBRAN ; IF DW MESS1-$ DW FCB ; DISK IS AVAILABLE DW PAD DW LIT,36 DW CMOVE DW FCB,ONEP DW LIT,35 DW ZERO,FILL DW LIT,ERRSTR DW FCBFN DDW $+2 ; (CR) ORPHAN PUSH B ; SAVE (IP) MVI C,ACR ; OUTPUT (CR) TO CONSOLE CALL CPOUT ; & MAYBE TO PRINTER MVI C,LF ; OUTPUT (LF) TO CONSOLE CALL CPOUT ; & MAYBE TO PRINTER POP B ; RESTORE (IP) JMP NEXT ; ;----------------------------------W LIT,11 DW CMOVE DW SOPEN DW LIT,255 DW EQUAL DW ZBRAN ; IF DW MESS4-$ DW PDOTQ DB 6,'MSG # ' DW DOT DW BRAN DW MESS5-$ MESS4: DW DUP,TWO DW SLASH DW RREAD DW ONE,ANDD DW ZBRAN ; IF DW MESS6-$ DW BUFF DW LIT,64 DW PL------------------ PAGE ; DB 0C1H ; ' ( TICK ) DB 0A7H DW EPRT-9 TICK: DW DOCOL DW DFIND DW ZEQU DW ZERO DW QERR DW DROP DW LITER DW SEMIS ; DB 86H ; FORGET DB 'FORGE' DB 'T'+80H DW TICK-4 FORG: DW DOCOL DW CURR DW AT US DW BRAN DW MESS7-$ MESS6: DW BUFF MESS7: DW LIT,64 DW DTRAI DW TYPE DW SPACE MESS5: DW PAD,FCB DW LIT,36 DW CMOVE MESS1: DW BRAN ; ELSE NO DISK ." MSG" DW MESS8-$ DW PDOTQ DB 6,'MSG # ' DW DOT MESS8: DW SEMIS PAGE ;------ DW CONT DW AT DW SUBB DW LIT DW 18H DW QERR DW TICK DW DUP DW FENCE DW AT DW LESS DW LIT DW 15H DW QERR DW DUP DW NFA DW DP DW STORE DW LFA DW AT DW CONT DW AT DW STORE DW SEMIS ; DB 84H ; BACK DB 'BAC' ------------------------------------ ; ; 8080 PORT FETCH AND STORE ; ( SELF MODIFYING CODE, NOT REENTRANT ) ; DB 82H ; P@ "PORT @" DB 'P' DB '@'+80H DW MESS-0AH PTAT: DW $+2 POP D ;E <- PORT# LXI H,$+5 MOV M,E IN 0 ;( PORT# MODIFIED )  DB 'K'+80H DW FORG-9 BACK: DW DOCOL DW HERE DW SUBB DW COMMA DW SEMIS ; DB 0C5H ; BEGIN DB 'BEGI' DB 'N'+80H DW BACK-7 BEGIN: DW DOCOL DW QCOMP DW HERE DW ONE DW SEMIS ; DB 0C5H ; ENDIF DB 'ENDI' DB 'F'+80H DW BEGIN- MOV L,A ;L <- (PORT#) MVI H,0 JMP HPUSH ; DB 82H ; "PORT STORE" DB 'P' DB '!'+80H DW PTAT-5 PTSTO: DW $+2 POP D ;E <- PORT# LXI H,$+7 MOV M,E POP H ;H <- CDATA MOV A,L OUT 0 ;( PORT# MODIFIED ) JMP NEXT PAGE ;------------8 ENDIFF: DW DOCOL DW QCOMP DW TWO DW QPAIR DW HERE DW OVER DW SUBB DW SWAP DW STORE DW SEMIS ; DB 0C4H ; THEN DB 'THE' DB 'N'+80H DW ENDIFF-8 THEN: DW DOCOL DW ENDIFF DW SEMIS ; DB 0C2H ; DO DB 'D' DB 'O'+80H DW T------------------------------------- ; ; CP/M CONSOLE & PRINTER INTERFACE ; ; CP/M BIOS CALLS USED ; ( NOTE: BELOW OFFSETS ARE 3 LOWER THAN CP/M ; DOCUMENTATION SINCE BASE ADDR = BIOS+3 ) ; KCSTAT EQU 3 ; CONSOLE STATUS KCIN EQU 6 ; CONSOLE INPHEN-7 DO: DW DOCOL DW COMP DW XDO DW HERE DW THREE DW SEMIS ; DB 0C4H ; LOOP DB 'LOO' DB 'P'+80H DW DO-5 LOOP: DW DOCOL DW THREE DW QPAIR DW COMP DW XLOOP DW BACK DW SEMIS ; DB 0C5H ; +LOOP DB '+LOO' DB 'P'+80H DW UT KCOUT EQU 9 ; CONSOLE OUTPUT KPOUT EQU 0CH ; PRINTER OUTPUT ; ; ************* ; * EPRINT * ; ************* ; DB 86H ; ENABLE PRINTER VARIABLE DB 'EPRIN' DB 'T'+80H DW PTSTO-5 EPRT: DW DOVAR EPRINT: DW 0 ; ENABLE PRINTER VARIABLLOOP-7 PLOOP: DW DOCOL DW THREE DW QPAIR DW COMP DW XPLOO DW BACK DW SEMIS ; DB 0C5H ; UNTIL DB 'UNTI' DB 'L'+80H DW PLOOP-8 UNTIL: DW DOCOL DW ONE DW QPAIR DW COMP DW ZBRAN DW BACK DW SEMIS ; DB 0C3H ; END DB 'EN' E ; ; 0 = DISABLED, 1 = ENABLED ; ; ; CP/M INTERFACE ROUTINES ; ; SERVICE REQUEST ; IOS: LHLD 1 ;(HL) <- BIOS TABLE ADDR+3 DAD D ; + SERVICE REQUEST OFFSET PCHL ; EXECUTE REQUEST ; RET FUNCTION PROVIDED BY CP/M ; ; BELOW BIOS CALLS USE DB 'D'+80H DW UNTIL-8 ENDD: DW DOCOL DW UNTIL DW SEMIS ; DB 0C5H ; AGAIN DB 'AGAI' DB 'N'+80H DW ENDD-6 AGAIN: DW DOCOL DW ONE DW QPAIR DW COMP DW BRAN DW BACK DW SEMIS ; DB 0C6H ; REPEAT DB 'REPEA' DB 'T'+80H DW AGAI 'IOS' ; CSTAT: PUSH B ; CONSOLE STATUS LXI D,KCSTAT ; CHECK IF ANY CHR HAS BEEN TYPED CALL IOS POP B ; IF CHR TYPED THEN (A) <- 0FFH RET ; ELSE (A) <- 0 ; ; CHR IGNORED ; CIN: PUSH B ; CONSOLE INPUT LXI D,KCIN ; WAIT FOR CHR TO BE TYPEDN-8 REPEA: DW DOCOL DW TOR DW TOR DW AGAIN DW FROMR DW FROMR DW TWO DW SUBB DW ENDIFF DW SEMIS ; DB 0C2H ; IF DB 'I' DB 'F'+80H DW REPEA-9 IFF: DW DOCOL DW COMP DW ZBRAN DW HERE DW ZERO DW COMMA DW TWO DW SEMIS ;5      DB 0C4H ; ELSE DB 'ELS' DB 'E'+80H DW IFF-5 ELSEE: DW DOCOL DW TWO DW QPAIR DW COMP DW BRAN DW HERE DW ZERO DW COMMA DW SWAP DW TWO DW ENDIFF DW TWO DW SEMIS ; DB 0C5H ; WHILE DB 'WHIL' DB 'E'+80H DW ELSEE-7 WHIL ;JMP TO COLD START MWARM EQU ORIG+4 ;JMP TO WARM START MA2 EQU ORIG+8 ;COLD START PARAMETERS MUP EQU UP ;USER VARIABLES' BASE 'REG' MRP EQU RPP ;RETURN STACK 'REGISTER' ; MDPUSH EQU DPUSH ;ADDRESS INTERPRETER MHPUSH EQU HPUSH MNEXT EQU NEXT E: DW DOCOL DW IFF DW TWOP DW SEMIS ; DB 86H ; SPACES DB 'SPACE' DB 'S'+80H DW WHILE-8 SPACS: DW DOCOL DW ZERO DW MAX DW DDUP DW ZBRAN ; IF DW SPAX1-$ DW ZERO DW XDO ; DO SPAX2: DW SPACE DW XLOOP ; LOOP ENDIF DW SPAX2-$ ; MDP0 EQU DP0 ;START FORTH DICTIONARY ;MDIO EQU DRIVE ;CP/M DISK INTERFACE MCIO EQU EPRINT ;CONSOLE & PRINTER INTERFACE MIDP EQU INITDP ;END INITIAL FORTH DICTIONARY ; = COLD (DP) VALUE ; = COLD (FENCE) VALUE ; | NEW ; SPAX1: DW SEMIS ; DB 82H ; <# DB '<' DB '#'+80H DW SPACS-9 BDIGS: DW DOCOL DW PAD DW HLD DW STORE DW SEMIS ; DB 82H ; #> DB '#' DB '>'+80H DW BDIGS-5 EDIGS: DW DOCOL DW DROP DW DROP DW HLD DW AT DW PAD DW OVER DW S | DEFINITIONS ; V ; ; ^ ; | DATA ; | STACK MIS0 EQU INITS0 ; = COLD (SP) VALUE = (S0) ; = (TIB) ; | TERMINAL INPUT ; | BUFFER ; V ; ; ^ ; | RETURN ; | STACK MIR0 EQU INITR0 ;UBB DW SEMIS ; DB 84H ; SIGN DB 'SIG' DB 'N'+80H DW EDIGS-5 SIGN: DW DOCOL DW ROT DW ZLESS DW ZBRAN ; IF DW SIGN1-$ DW LIT DW 2DH DW HOLD ; ENDIF SIGN1: DW SEMIS ; DB 81H ; # DB '#'+80H DW SIGN-7 DIG: DW DOCOL DW BASE START USER VARIABLES ; = COLD (RP) VALUE = (R0) ; = (UP) ; ;END USER VARIABLES MFIRST EQU BUF1 ;START DISK BUFFERS ; = FIRST MEND EQU EM-1 ;END DISK BUFFERS MLIMIT EQU EM ;LAST MEMORY LOC USED + 1 ; = LIMIT ; ; END ORI DW AT DW MSMOD DW ROT DW LIT DW 9 DW OVER DW LESS DW ZBRAN ; IF DW DIG1-$ DW LIT DW 7 DW PLUS ; ENDIF DIG1: DW LIT DW 30H DW PLUS DW HOLD DW SEMIS ; DB 82H ; #S DB '#' DB 'S'+80H DW DIG-4 DIGS: DW DOCOL DIGS1: DW G FERS ; = FIRST MEND EQU EM-1 ;END DISK BUFFERS MLIMIT EQU EM ;LAST MEMORY LOC USED + 1 ; = LIMIT ; ; END ORIDIG ; BEGIN DW OVER DW OVER DW ORR DW ZEQU DW ZBRAN ; UNTIL DW DIGS1-$ DW SEMIS ; DB 83H ; D.R DB 'D.' DB 'R'+80H DW DIGS-5 DDOTR: DW DOCOL DW TOR DW SWAP DW OVER DW DABS DW BDIGS DW DIGS DW SIGN DW EDIGS DW FROMR  FORTH HI-LEVEL WORDS TO ASSEMBLY LABELS CONVERSION Forth Word Assembly Label ---------- -------------- LIT LIT EXECUTE EXEC BRANCH BRAN 0BRANCH ZBRAN (LOOP) XLOOP (+LOOP) XPLOOP (DO) XDO I IDO DIGIT DIGIT (FIND) PFI DW OVER DW SUBB DW SPACS DW TYPE DW SEMIS ; DB 82H ; .R DB '.' DB 'R'+80H DW DDOTR-6 DOTR: DW DOCOL DW TOR DW STOD DW FROMR DW DDOTR DW SEMIS ; DB 82H ; D. DB 'D' DB '.'+80H DW DOTR-5 DDOT: DW DOCOL DW ZERO DW DDND ENCLOSE ENCL EMIT EMIT KEY KEY ?TERMINAL QTERM CR CR CMOVE CMOVE U* USTAR U/ USLAS AND ANDD OR ORR XOR XORR SP@ SPAT SP! SPSTO RP@ RPAT RP! RPSTO ;S SEMIS LEAVE LEAVE >R TOR R> FROMR R RR 0= ZEQU 0< ZLESS + POTR DW SPACE DW SEMIS ; DB 81H ; . DB '.'+80H DW DDOT-5 DOT: DW DOCOL DW STOD DW DDOT DW SEMIS ; DB 81H ; ? DB '?'+80H DW DOT-4 QUES: DW DOCOL DW AT DW DOT DW SEMIS ; DB 82H ; U. DB 'U' DB '.'+80H DW QUES-4 UDOT: DLUS D+ DPLUS MINUS MINUS DMINUS DMINU OVER OVER DROP DROP SWAP SWAP DUP DUP 2DUP TDUP +! PSTOR TOGGLE TOGGL @ AT C@ CAT 2@ TAT ! STORE C! CSTOR Forth Word Assembly Label ---------- -------------- 2! TSTOR : DOCOL ; SW DOCOL DW ZERO DW DDOT DW SEMIS ; DB 85H ; VLIST DB 'VLIS' DB 'T'+80H DW UDOT-5 VLIST: DW DOCOL DW LIT DW 80H DW OUTT DW STORE DW CONT DW AT DW AT VLIS1: DW OUTT ; BEGIN DW AT DW CSLL DW GREAT DW ZBRAN ; IF DW VLISEMI NOOP NOOP CONSTANT DOCON VARIABLE DOVAR USER DOUSE 0 ZERO 1 ONE 2 TWO 3 THREE BL BL C/L CSLL FIRST FIRST LIMIT LIMIT B/BUF BBUF B/SCR BSCR +ORIGIN PORIG S0 SZERO R0 RZERO TIB TIB WIDTH WIDTH WARNING WARN FENCE FE2-$ DW CR DW ZERO DW OUTT DW STORE ; ENDIF VLIS2: DW DUP DW IDDOT DW SPACE DW SPACE DW PFA DW LFA DW AT DW DUP DW ZEQU DW QTERM DW ORR DW ZBRAN ; UNTIL DW VLIS1-$ DW DROP DW SEMIS ; ;------ EXIT CP/M ----------------NCE DP DP VOC-LINK VOCL BLK BLK IN INN OUT OUTT SCR SCR OFFSET OFSET CONTEXT CONT CURRENT CURR STATE STATE BASE BASE DPL DPL FLD FLD CSP CSPP R# RNUM HLD HLD 1+ ONEP 2+ TWOP HERE HERE ALLOT ALLOT , COMMA C, CCOMM ------- ; DB 83H ; BYE DB 'BY' DB 'E'+80H DW VLIST-8 BYE: DW $+2 JMP 0 ;----------------------------------------------- PAGE ; ******************************* ; *** "NEXT" CONSTANT *** ; ******************************* ; ; USE - SUBB = EQUAL < LESS U< ULESS > GREAT ROT ROT SPACE SPACE Forth Word Assembly Label ---------- -------------- -DUP DDUP TRAVERSE TRAV LATEST LATES LFA LFA CFA CFA NFA NFA PFA PFA !CSP SCSP ?ERROR QERR ?COMP QCOMP ?EXED BY THE ASSEMBLER EXTENSION ; DB 84H ; NEXT DB 'NEX' DB 'T'+80H DW BYE-6 NNEXT: DW DOCON DW NEXT ; ********************** ; *** "TASK" *** ; ********************** ; ; THE LAST WORD IN THE DICTIONARY ; DB 84H ; TASK DB 'C QEXEC ?PAIRS QPAIR ?CSP QCSP ?LOADING QLOAD COMPILE COMP [ LBRAC ] RBRAC SMUDGE SMUDG HEX HEX DECIMAL DEC (;CODE) PSCOD ;CODE SEMIC DOES DOES COUNT COUNT TYPE TYPE -TRAILING DTRAI (.") PDOTQ ." DOTQ EXPETAS' DB 'K'+80H DW NNEXT-7 TASK: DW DOCOL DW SEMIS ; INITDP: ; DS EM-$ ;CONSUME MEMORY TO LIMIT ; PAGE ; ; MEMORY MAP ; ( THE FOLLOWING EQUATES ARE NOT REFERENCED ELSEWHERE ) ; ; LOCATION CONTENTS ; -------- -------- MCOLD EQU ORIG CT EXPEC QUERY QUERY X NULL FILL FILL ERASE ERASEE BLANKS BLANK HOLD HOLD PAD PAD WORD WORD SP.FIND SPFIND WHERE WHERE FPTR FPTR ?TLOAD TLOADV WARN WARNU DBUFF1 DBUFF1 DBUFF2 DBUFF2 (NUMBER) PNUMB NUMBER NUMB -FIND DFIND6      (ABORT) PABOR ERROR ERROR ID. IDDOT CREATE CREAT [COMPILE] DCOMP LITERAL LITER Forth Word Assembly Label ---------- -------------- DLITERAL DLITE ?STACK QSTAC INTERPRET INTER IMMEDIATE IMMED VOCABULARY VOCAB FORTH FORTH DEFINITIONSOR ( DISK ERROR STATUS ) DB 'DISK-ERRO' DB 'R'+80H DW NOBUF-8 DSKERR: DW DOVAR,0 ; ; DISK INTERFACE HIGH-LEVEL ROUTINES ; DB 84H ; +BUF ( ADVANCE BUFFER ) DB '+BU' DB 'F'+80H DW DSKERR-13 PBUF: DW DOCOL DW LIT,CO DW PLUS,DUP DW LI DEFIN ( PAREN QUIT QUIT ABORT ABORT WARM WARM COLD COLD S->D STOD +- PM D+- DPM ABS ABS DABS DABS MIN MIN MAX MAX M* MSTAR M/ MSLAS * STAR /MOD SLMOD / SLASH MOD MODD */MOD SSMOD */ SSLA M/MOD MSMOD MIT,EQUAL DW ZBRAN,PBUF1-$ DW DROP,FIRST PBUF1: DW DUP,PREV DW AT,SUBB DW SEMIS ; DB 86H ; UPDATE DB 'UPDAT' DB 'E'+80H DW PBUF-7 UPDAT: DW DOCOL,PREV DW AT,AT DW LIT,8000H DW ORR DW PREV,AT DW STORE,SEMIS ; DB 8DH ; EMPTY-BUFFERS DB 'EMPTY-BUFFER' DB 'S'+80H DW UPDAT-9 MTBUF: DW DOCOL,FIRST DW LIMIT,OVER DW SUBB,ERASEE DW SEMIS ; DB 83H ; DR0 DB 'DR' DB '0'+80H DW MTBUF-16 DRZER: DW DOCOL,ZERO DW OFSET,STORE DW SEMIS ; DB 83H ; DR1 DB 'DR' DB '1'+80H DW DRZER-6 DRONE: DW DOCOL DW LIT,250 DW OFSET,STORE DW SEMIS ; DB 86H ; BUFFER DB 'BUFFE' DB 'R'+80H DW DRONE-6 BUFFE: DW DOCOL,USE DW AT,DUP DW TOR BUFF1: DW PBUF ; WON'T WORK IF SINGLE BUFFER DW ZBRAN,BUFF1-$ DW USE,STORE DW RR,AT DW ZLESS DW ZBRAN,BUFF2-$ DW RR,TWOP DW RR,AT DW LIT,7FFFH DW ANDD,ZERO DW RSLW BUFF2: DW RR,STORE DW RR,PREV DW STORE,FROMR DW TWOP,SEMIS ; DB 85H ; BLOCK DB 'BLOC' DB 'K'+80H DW BUFFE-9 BLOCK: DW DOCOL,OFSET DW AT,PLUS DW TOR,PREV DW AT,DUP DW AT,RR DW SUBB DW DUP,PLUS DW ZBRAN,BLOC1-$ BLOC2: DW PBUF,ZEQU DW ZBRAN,BLOC3-$ DW DROP,RR DW BUFFE,DUP DW RR,ONE DW RSLW DW TWO,SUBB BLOC3: DW DUP,AT DW RR,SUBB DW DUP,PLUS DW ZEQU  DW ZBRAN,BLOC2-$ DW DUP,PREV DW STORE BLOC1: DW FROMR,DROP DW TWOP,SEMIS PAGE ; ; CP/M INTERFACE ROUTINES ; ; SERVICE REQUEST ; IOS: LHLD 1 ;(HL) <- BIOS TABLE ADDR+3 DAD D ; + SERVICE REQUEST OFFSET PCHL ; EXECUTE REQUEST ; RET FUNCTION PROVIDED BY CP/M ; DB 86H ; SET-IO ; ( ASSIGN SECTOR, TRACK FOR BDOS ) DB 'SET-I' DB 'O'+80H DW BLOCK-8 SETIO: DW $+2 PUSH B ; SAVE (IP) LHLD USE+2 ; (BC) <- ADDR BUFFER MOV B,H MOV C,L LXI D,SETDMA ; SEND BUFFER ADDR TO CP/M;-------------------------------------------------- ; CP/M DISK INTERFACE ; ; CP/M BIOS CALLS USED ; ( NOTE EQU'S ARE 3 LOWER THAN DOCUMENTED OFFSETS ; BECAUSE BASE ADDR IS BIOS+3 ) ; RITSEC EQU 39 RDSEC EQU 36 SETDMA EQU 33 SETSEC EQU 30 SETT CALL IOS ; LHLD SEC+2 ; (BC) <- (SEC) = SECTOR # MOV C,L LXI D,SETSEC ; SEND SECTOR # TO CP/M CALL IOS ; LHLD TRACK+2 ; (BC) <- (TRACK) = TRACK # MOV B,H MOV C,L LXI D,SETTRK CALL IOS ; POP B ; RESTORE (IP) JMP NEXT ; DB 89H RK EQU 27 SETDSK EQU 24 ; ; SINGLE DENSITY 8" FLOPPY CAPACITIES SPT1 EQU 26 ; SECTORS/TRACK TRKS1 EQU 77 ; # TRACKS SPDRV1 EQU SPT1*TRKS1 ; SECTORS/DRIVE ; BPS EQU 128 ; BYTES PER SECTOR MXDRV EQU 2 ; MAX # DRIVES ; ; FORTH VARIABLES AND CONSTAN; SET-DRIVE DB 'SET-DRIV' DB 'E'+80H DW SETIO-9 SETDRV: DW $+2 PUSH B ; SAVE (IP) LDA DRIVE+2 ; (C) <- (DRIVE) = DRIVE # MOV C,A LXI D,SETDSK ; SEND DRIVE # TO CP/M CALL IOS POP B ; RESTORE (IP) JMP NEXT PAGE ; *************** TS USED IN DISK INTERFACE ; DB 85H ; DRIVE ( CURRENT DRIVE # ) DB 'DRIV' DB 'E'+80H DW PTSTO-5 DRIVE: DW DOVAR,0 ; DB 83H ; SEC ( SECTOR # ) DB 'SE' DB 'C'+80H DW DRIVE-8 SEC: DW DOVAR DW 0 ; DB 85H ; TRACK ( TRACK # ) DB 'TRAC' ; * T&SCALC * ; *************** ; ; ( CALCULATES DRIVE#, TRACK#, & SECTOR# ) ; STACK INPUT: SECTOR-DISPLACEMENT = BLK# * SEC/BLK ; OUTPUT: VARIABLES DRIVE, TRACK, & SEC ; DB 87H ; T&SCALC DB 'T&SCAL' DB 'C'+80H DW SETDRV-12 TSCALC: DW DO DB 'K'+80H DW SEC-6 TRACK: DW DOVAR,0 ; DB 83H ; USE ( ADDR OF NEXT BUFFER TO USE ) DB 'US' DB 'E'+80H DW TRACK-8 USE: DW DOVAR DW BUF1 ; DB 84H ; PREV ; ( ADDR OF PREVIOUSLY USED BUFFER ) DB 'PRE' DB 'V'+80H DW USE-6 PREV: DWCOL DW LIT,2000 DW SLMOD DW LIT,MXDRV DW MIN DW DUP,DRIVE DW AT,EQUAL DW ZBRAN,TSCAL3-$ DW DROP DW BRAN,TSCAL4-$ TSCAL3: DW DRIVE,STORE DW SETDRV TSCAL4: DW LIT,SPT1 DW SLMOD,TRACK DW STORE,ONEP DW SEC,STORE DW SEMIS PAGE  DOVAR DW BUF1 ; DB 87H ; SEC/BLK ( # SECTORS/BLOCK ) DB 'SEC/BL' DB 'K'+80H DW PREV-7 SPBLK: DW DOCON DW KBBUF/BPS ; DB 85H ; #BUFF ( NUMBER OF BUFFERS ) DB '#BUF' DB 'F'+80H DW SPBLK-10 NOBUF: DW DOCON,NBUF ; DB 8AH ; DISK-ERR ; **************** ; * SEC-READ * ; **************** ; ; ( READ A SECTOR SETUP BY 'SET-DRIVE' & 'SETIO' ) ; DB 88H DB 'SEC-REA' DB 'D'+80H DW TSCALC-10 SECRD: DW $+2 POP D ; READ/WRITE CMD MOV A,E ORA A ; TEST IT LXI D,RDSEC 7      ; READ SECTOR? JNZ SECRD1 ; YES YES YES LXI D,RITSEC ; WRITE SECTOR SECRD1: PUSH B ; SAVE (IP) LDA SEC+2 MOV C,A ; CURRENT SECTOR # LHLD USE+2 ; DMA ADDRESS MVI B,8 ; SECTOR COUNT ; READ/WRITE SECTOR LOOP ; RWSEC1: PUSH B ; SAVE RE+ EMIT ." : " ; : .NAME ( PRINT THE NAME OF THE FILE ) BUFF 1+ SCRATCH @ 32 * + DUP 8 TYPE SPACE 8 + 3 TYPE 1 COL.CTR +! COL.CTR @ 4 = IF CR .DR: 0 COL.CTR ! ELSE ." : " THEN ; : DIR ( SCAN DIRECTORY ) CR GS PUSH H PUSH D ; READ/WRITE ADDR RWSEC2: LXI D,SETSEC CALL IOS ; SET THE SECTOR POP D POP B ; DMA PUSH B PUSH D LXI D,SETDMA CALL IOS ; SET THE DMA POP D ; READ/WRITE CMD PUSH D CALL IOS ; READ OR WRITE MOV B,A ; SAVE ERFNAME>? ( SET FNAME TO ? ) 0 COL.CTR ! .DR: *SFIRST ( START SCAN ) 255 - IF 0 SCRATCH ! .NAME ( FIRST ENTRY ) BEGIN *SNEXT DUP SCRATCH ! 255 - WHILE .NAME ( PRINT NAME ) REPEAT CR THEN FCBROR STATUS LDA DSKERR+2 ORA B ; COMBINE ERRORS STA DSKERR+2 ; SAVE DISK STATUS POP D POP H ; DMA ADDR LXI B,128 DAD B ; NEXT ADDR POP B DCR B ; SECTOR COUNT -1 JZ RWDONE ; FINISHED INR C ; SECTOR +1 MOV A,C CPI 27 JC RWSECFN 11 32 FILL ; ( *SWRITE -- SEQUENTIAL WRITE ) CODE *SWRITE B PUSH ( SAVE INTERPRETIVE POINTER ) HEX 15 C MVI BDOSCMD JMP C; ( **** CPM -- CP/M ENHANCEMENT PACKAGE ******************** ) DECIMAL1 ; NEXT SECTOR ; END OF TRACK, SEEK TO NEXT TRACK LDA TRACK+2 INR A STA TRACK+2 MVI C,1 ; SECTOR 1 PUSH B PUSH H PUSH D MOV C,A ; NEW TRACK # LXI D,SETTRK CALL IOS ; SEEK MVI C,1 ; SECTOR 1 JMP RWSEC2 ; NEXT SECTOR ; 10 : OPEN/MAKE ( OPEN OR MAKE A FILE IN FNAME ) *OPEN 255 = IF MAKE THEN 0 C.REC C! ; : WRITED *SWRITE IF ." DISC WRITE ERROR" QUIT THEN ; ;S 24 BYTES READ ; RWDONE: POP B ; GET BACK (IP) JMP NEXT PAGE ; *********** ; * R/W * ; *********** ; DB 83H DB 'R/' DB 'W'+80H DW SECRD-11 RSLW: DW DOCOL DW USE,AT DW TOR DW SWAP,SPBLK DW STAR,ROT DW USE,STORE DW TSCALC,SETIO DW SECRD DW FROMR,USE DW STORE,SEMIS ( **** CPM -- CP/M ENHANCEMENT PACKAGE ******************** ) ( UPDATED: 01/05/84 BY NAA ) CODE *MAKE ( MAKE THE FILE ) B PUSH ( SAVE INTERPRETIVE POINTER ) MAKEFC C MVI BDOSCMD JMP C; : MAKE ( MAKE A FILE FROM THE CURRENT FCB ) *MAKE ( MACHINE CODE ) 255 = IF ( PRINT ) CR ." NOT ENOUGH ROOM IN DIRECTORY" QUIT THEN ; : CREATE ( ASK FOR THE FILE AND CREATE IT ) KEY>FNAME MAKE ; CODE *ERA ( ERASE A CP/M FILE IN DIRECTORY ) B PUSH ( SAVE INTERPRETIVE POINTER ) 19 C MVI BDOSCMD JMP C; : (ERA) ( ERASE THE FILE IN FCB ) *ERA ( MACHINE LANGUAGE ) 255 = IF .NOFILE THEN ; : ERA ( ASK FOR FILE AND DELETE ) KEY>FNAME (ERA) ; CODE *CLOSE ( CLOSE A FILE ) B PUSH ( SAVE POINTER ) 16 C MVI BDOSCMD JMP C; : CLOSE ( CLOSE THE FILE IN FNAME ) *CLOSE 255 = IF .NOFILE THEN ; ( SEQUENTIAL FILE READ -- *SREAD ) CODE *SREAD XSUB M80 =B:$1 L80 /D:0,/P:0100,B:FORTHBAS,B:4THCOMP5,B:FORTH5/X/N:P/Y /E ZSID IB:FORTH5.HEX B:FORTH5.SYM R FORTHBASBAK0 ( SEQUENTIAL READ ) B PUSH ( INTERPRETIVE POINTER ) HEX 14 C MVI DECIMAL ( READ CODE ) BDOSCMD JMP C; ( **** CPM -- CP/M ENHANCEMENT PACKAGE ******************** ) ( SFIRST, SNEXT -- SEARCH DIRECTORY FUNCTIONS ) CODE *SFIRST B PUSH ( SAVE INT PTR ) HEX 11 C MVI ( FUNCTION CODE ) BDOSCMD JMP ( DO BDOS COMMAND ) C; CODE *SNEXT B PUSH ( SAVE INT PTR ) HEX 12 C MVI ( FUNCTION CODE ) BDOSCMD JMP ( DO BDOS COMMAND ) C; DECIMAL ( DIR -- PRINT DIRECTORY ) 00 VARIABLE SCRATCH 00 VARIABLE COL.CTR ( COLUMN COUNTER ) : FNAME>? ( SET FILE NAME AMBIGUOUS ) FCBFN 11 63 FILL ( FILE NAME TO ? ) ; : .DR: ( PRINT DRIVE AND COLEN ) FCB C@ 64 8     SING EXTRN WORD EXTRN QTLOAD EXTRN NXTBLK PAGE ; ASCII CHARACTERS USED ; ABL EQU 20H ; SPACE ACR EQU 0DH ; CARRIAGE RETURN ADOT EQU 02EH ; PERIOD BELL EQU 07H ; (^G) BSIN EQU 08H ; INPUT BACKSPACE CHR = (^H)--MOD NAA BSOUT EQU 08H ; OUTPUT BACKSPACE (^H) DLE EQU 10H ; (^P) LF EQU 0AH ; LINE FEED FF EQU 0CH ; FORM FEED (^L) ; ; MEMORY ALLOCATION ; EM EQU 7A00H ; TOP OF MEMORY + 1 = LIMIT NSCR EQU 2 ; NUMBER OF 1024 BYTE SCREENS KBBUF EQU 1024 ; DATA BYTES PER DISK BUFFER US EQU 40H ; USER VARIABLES SPACE RTS EQU 0A0H ; RETURN STACK & TERM BUFF SPACE ; CO EQU KBBUF+4 ; DISK BUFFER + 2 HEADER + 2 TAIL NBUF EQU NSCR*400H/KBBUF ; NUMBER OF BUFFERS BUF1 EQU EM-CO*NBUF ; ADDR FIRST DISK BUFFER INITR0 EQU BUF1-US ; (R0) INITS0 EQU INITR0-RTS ; (S0) ; PAGE ; ;------------------------------------------------------- ; ORG 0H ORIG: NOP JMP CLD ; VECTOR TO COLD START ; NOP JMP WRM ; VECTOR TO WARM START ; DB FIGREL ; FIG RELEASE # DB FIGREV ; FIG REVISION # D TITLE '8080 FIG-FORTH 4THCOMP BASE CODE (09/18/84)' ;**************************************************************** ; ; ; 8080 FIG-FORTH 4THCOMP ; ; ; ; CONCEIVED BY NICK AVDONIN 09/18/84 ; ; UPDATED: 09/18/84 ; B USRVER ; USER VERSION # DB 0EH ; IMPLEMENTATION ATTRIBUTES DW TASK-7 ; TOPMOST WORD IN FORTH VOCABULARY DW BSIN ; BKSPACE CHARACTER DW INITR0 ; INIT (UP) ;<<<<<< FOLLOWING USED BY COLD; ; MUST BE IN SAME ORDER AS USER VARIABLES DW INITS0 ; I; ; ; BASE NUCLEUS RELOCATABLE MODULE ; ; ; ;**************************************************************** ; ; RELEASE & VERSION NUMBERS ; FIGREL EQU 4 ; FIG RELEASE # FIGREV EQU 1 ; FIG REVISION # ;USRVER EQU 0 ; USER VERSNIT (S0) DW INITR0 ; INIT (R0) DW INITS0 ; INIT (TIB) DW 20H ; INIT (WIDTH) DW 1 ; INIT (WARNING) DW INITDP ; INIT (FENCE) DW INITDP ; INIT (DP) DW FORTH+6 ; INIT (VOC-LINK) ;<<<<<< END DATA USED BY COLD DW 5H,0B320H ; CPU NAME ( HW,LION # ; ; ALL PUBLICATIONS OF THE FORTH INTEREST GROUP ; ARE PUBLIC DOMAIN. THEY MAY BE FURTHER ; DISTRIBUTED BY THE INCLUSION OF THIS CREDIT ; NOTICE: ; ; THIS PUBLICATION HAS BEEN MADE AVAILABLE BY THE ; FORTH INTEREST GROUP ; W ) ; ( 32 BIT, BASE 36 INTEGER ) ; ; ; +---------------+ ; B +ORIGIN | . . .W:I.E.B.A| IMPLEMENTATION ; +---------------+ ATTRIBUTES ; ^ ^ ^ ^ ^ ; | | | | +-- PROCESSOR ADDR = ; | | | | { 0 BYTE | 1 WORD }  P. O. BOX 1105 ; SAN CARLOS, CA 94070 ; ; MODIFICATIONS BY NICK AVDONIN ; 1. REMOVED DISK I/O, BLOCK STRUCTURE ; ADDED FORTH COMP, CP/M STRUCTURE. ; FORTH COMP, COPYRIGHT 1984 BY NICK AVDONIN ; 2. INITIALIZE WARNING TO 1 -- DISK AVA ; | | | +---- HIGH BYTE AT ; | | | { 0 LOW ADDR | ; | | | 1 HIGH ADDR } ; | | +------ ADDR MUST BE EVEN ; | | { 0 YES | 1 NO } ; | +-------- INTERPRETER IS ; | { 0 PRE |ILABLE ; 3. 'COLD' SHOULD NOT EMPTY-BUFFERS ; 4. INPUT DELETE CHANGED TO BACKSPACE -- 08H PAGE ; GLOBAL SYMBOLS DEFINED GLOBAL AT,ANDD,ALLOT GLOBAL BASE,BLK,BUILD,BRAN,BLANK,BL GLOBAL CAT,CSLL,COMP,CURR,COMMA,CFA,CSTOR,CMOVE,CR,C 1 POST } ; | INCREMENTING ; +---------- { 0 ABOVE SUFFICIENT ; | 1 OTHER DIFFER- ; ENCES EXIST } ; PAGE ; ;------------------------------------------------------ ; ; FORTH REGISTERS ; ; FORTH 8080 FORTH OUNT,CONT GLOBAL DIGIT,DEC,DOES,DODOE,DMINU,DPLUS,DPL,DOVAR GLOBAL DOCON,DP0,DDUP,DP,DTRAI,DPUSH,DOCOL,DROP,DUP GLOBAL ENCL,EQUAL,EXEC GLOBAL FROMR,FILL,FENCE GLOBAL GREAT GLOBAL HERE,HLD,HOLD,HPUSH GLOBAL INN,IDO GLOBAL LIT,LBRAC,LFA,LEAVEPRESERVATION RULES ; ----- ---- ------------------------ ; IP BC SHOULD BE PRESERVED ACROSS ; FORTH WORDS ; W DE SOMETIMES OUTPUT FROM NEXT ; MAY BE ALTERED BEFORE JMP'ING TO NEXT ; INPUT ONLY WHEN 'DPUSH' CALLED ; SP SP SHOULD BE USED ONLY ,LESS,LATES GLOBAL MINUS GLOBAL NEXT,NFA,NOOP GLOBAL ORIG,ORR,OUTT,OVER,ONE,ONEP GLOBAL PLUS,PAD,PFA,PSTOR,PDOTQ,PFIND GLOBAL QERR,QUERY,QCOMP,QPAIR,QTERM GLOBAL RR,ROT,RPP,RPSTO GLOBAL SWAP,SZERO,SPSTO,SPAT,STATE,SEMIS,STORE,SUBB,SEMIS,SPACEAS DATA STACK ; ACROSS FORTH WORDS ; MAY BE USED WITHIN FORTH WORDS ; IF RESTORED BEFORE 'NEXT' ; HL NEVER OUTPUT FROM NEXT ; INPUT ONLY WHEN 'HPUSH' CALLED ; UP: DW INITR0 ; USER AREA POINTER RPP: DW INITR0 ; RETURN STACK POINTER ;  GLOBAL TIB,TWO,TWOP,THREE,TDUP,TOR,TOGGL,TYPE GLOBAL USTAR,UP,ULESS,USLAS GLOBAL VOCL GLOBAL WARN,WIDTH GLOBAL XDO,XPLOO,XORR,XLOOP GLOBAL ZEQU,ZLESS,ZBRAN,ZERO ; EXTERNAL SYMBOLS DEFINED EXTRN CLD ; COLD START EXTRN WRM ; WARM START ;------------------------------------------------------ ; ; COMMENT CONVENTIONS: ; ; = MEANS "IS EQUAL TO" ; <- MEANS ASSIGNMENT ; ; NAME = ADDRESS OF NAME ; (NAME) = CONTENTS AT NAME ; ((NAME))= INDIRECT CONTENTS ; ; CFA = ADDRESS OF CODE FIELD EXTRN TASK ; TOP MOST WORD IN FORTH VOC EXTRN INITDP ; INITIAL DICTIONARY POINTER EXTRN FORTH ; INITIAL VOCABULARY LINK EXTRN PEMIT ; PRINTER EMIT EXTRN PKEY ; KEYBOARD EXTRN PQTER EXTRN PCR EXTRN CREAT ; CREATE EXTRN ERROR ; ERROR PROCES ; LFA = ADDRESS OF LINK FIELD ; NFA = ADDR OF START OF NAME FIELD ; PFA = ADDR OF START OF PARAMETER FIELD ; ; S1 = ADDR OF 1ST WORD OF PARAMETER STACK ; S2 = ADDR OF 2ND WORD OF PARAMETER STACK ; R1 = ADDR OF 1ST WORD OF RETURN STACK ; R2 = ADDR 9     OF 2ND WORD OF RETURN STACK ; ( ABOVE STACK POSITIONS VALID BEFORE & AFTER EXECUTION ; OF ANY WORD, NOT DURING. ) ; ; LSB = LEAST SIGNIFICANT BIT ; MSB = MOST SIGNIFICANT BIT ; LB = LOW BYTE ; HB = HIGH BYTE ; LW = LOW WORD ; HW = HIGH WORD ; ( MW $+2 POP H ; (L) <- (S1)LB = ASCII CHR TO BE ; CONVERTED POP D ; (DE) <- (S2) = BASE VALUE MOV A,E SUI 30H ; IF CHR > "0" JM DIGI2 CPI 0AH ; AND IF CHR > "9" JM DIGI1 SUI 7 CPI 0AH ; AND IF CHR >= "A" JM DIGI2 ; ; THEN VALID NUMAY BE USED AS SUFFIX TO ABOVE NAMES ) ; PAGE ;-------------------------------------------------- ; ; NEXT, THE FORTH ADDRESS INTERPRETER ; ( POST INCREMENTING VERSION ) ; ; ; DPUSH: PUSH D HPUSH: PUSH H NEXT: CNEXT: LDAX B ;(W) <- ((IP)) ERIC OR ALPHA CHR DIGI1: CMP L ; IF < BASE VALUE JP DIGI2 ; ; THEN VALID DIGIT CHR MOV E,A ; (S2) <- (DE) = CONVERTED DIGIT LXI H,1 ; (S1) <- TRUE JMP DPUSH ; ; ELSE INVALID DIGIT CHR DIGI2: MOV L,H ; (HL) <- FALSE JMP HPUSH ; (S1) <- FALINX B ;(IP) <- (IP)+2 MOV L,A LDAX B INX B MOV H,A ; (HL) <- CFA NEXT1: MOV E,M ;(PC) <- ((W)) INX H MOV D,M XCHG PCHL ; NOTE: (DE) = CFA+1 PAGE ; FORTH DICTIONARY ; ; ; DICTIONARY FORMAT: ; ; BYTE ; ADDRESS NAME CONTENTSE ; DB 86H ; (FIND) (2-1)FAILURE DB '(FIND' ; (2-3)SUCCESS DB ')'+80H DW DIGIT-8 PFIND: DW $+2 POP D ; (DE) <- NFA PFIN1: POP H ; (HL) <- STRING ADDR PUSH H ; SAVE STRING ADDR FOR NEXT ITERATION LDAX D XRA M ; CHECK LENGTHS & SMUDGE BIS ; ------- ---- -------- ; ( MSB=1 ; ( P=PRECEDENCE BIT ; ( S=SMUDGE BIT ; NFA NAME FIELD 1PS < NAME LENGTH ; 0<1CHAR> MSB=0, NAME'S 1ST CHAR ; 0<2CHAR> ; ... ; 1 MSB=1, NAME'S LAST CHR ; LFA LINK T ANI 3FH JNZ PFIN4 ; LENGTHS DIFFERENT ; ; LENGTHS MATCH, CHECK EACH CHR PFIN2: INX H ; (HL) <- ADDR NEXT CHR IN STRING INX D ; (DE) <- ADDR NEXT CHR IN NF LDAX D XRA M ; IGNORE MSB ADD A JNZ PFIN3 ; NO MATCH JNC PFIN2 ; MATCH SO FAR, FIELD = PREVIOUS WORD'S NFA ; ;LABEL: CFA CODE FIELD = ADDR CPU CODE ; ; PFA PARAMETER <1PARAM> 1ST PARAMETER BYTE ; FIELD <2PARAM> ; ... ; ; DP0: DB 83H ; LIT DB 'LI' DB 'T'+80H DW 0 ; ZERLOOP AGAIN LXI H,5 ; STRING MATCHES DAD D ; ((SP)) <- PFA XTHL ; ; BACK UP TO LENGTH BYTE OF NF = NFA PFIN6: DCX D LDAX D ORA A JP PFIN6 ; IF MSB = 1 THEN (DE) = NFA MOV E,A ; (DE) <- LENGTH BYTE MVI D,0 LXI H,1 ; (HL) <- TRUE JMP DO LINK LIT: DW $+2 ;(S1) <- ((IP)) LDAX B ; (HL) <- ((IP)) = LITERAL INX B ; (IP) <- (IP) + 2 MOV L,A ; LB LDAX B ; HB INX B MOV H,A JMP HPUSH ; (S1) <- (HL) ; DB 87H ; EXECUTE DB 'EXECUT' DB 'E'+80H DW LIT-6 EXEC: DW $+2 POP H PUSH ; RETURN, NF FOUND ; ABOVE NF NOT A MATCH, TRY ANOTHER PFIN3: JC PFIN5 ; IF NOT END OF NF PFIN4: INX D ; THEN FIND END OF NF LDAX D ORA A JP PFIN4 PFIN5: INX D ; (DE) <- LFA XCHG MOV E,M ; (DE) <- (LFA) INX H MOV D,M MOV A,D ORA; (HL) <- (S1) = CFA JMP NEXT1 ; DB 86H ; BRANCH DB 'BRANC' DB 'H'+80H DW EXEC-0AH BRAN: DW $+2 ;(IP) <- (IP) + ((IP)) BRAN1: MOV H,B ; (HL) <- (IP) MOV L,C MOV E,M ; (DE) <- ((IP)) = BRANCH OFFSET INX H MOV D,M DCX H DAD D ; (HL)  E ; IF (LFA) <> 0 JNZ PFIN1 ; THEN TRY PREVIOUS DICT. DEF. ; ; ELSE END OF DICTIONARY POP H ; DISCARD STRING ADDR LXI H,0 ; (HL) <- FALSE JMP HPUSH ; RETURN, NO MATCH FOUND PAGE ; *************** ; * ENCLOSE * ; *************** <- (HL) + ((IP)) MOV C,L ; (IP) <- (HL) MOV B,H JMP NEXT ; DB 87H ; 0BRANCH DB '0BRANC' DB 'H'+80H DW BRAN-9 ZBRAN: DW $+2 POP H MOV A,L ORA H JZ BRAN1 ; IF (S1)=0 THEN BRANCH INX B ; ELSE SKIP BRANCH OFFSET INX B JMP NEXT ; ; ; MODIFIED FROM THE 'FIG' VERSION TO ALLOW ; SEARCHES UP TO 65535 BYTES. ; (PREVIOUSLY ON 8-BITS; 256 BYTES) ; DB 87H ; ENCLOSE DB 'ENCLOS' DB 'E'+80H DW PFIND-9 ENCL: DW $+2 POP D ; (DE) <- (S1) = DELIMITER CHAR POP H ; (HL) <- (S2) = A DB 86H ; (LOOP) DB '(LOOP' DB ')'+80H DW ZBRAN-0AH XLOOP: DW $+2 LXI D,1 ; (DE) <- INCREMENT XLOO1: LHLD RPP ; ((HL)) = INDEX MOV A,M ; INDEX <- INDEX + INCR ADD E MOV M,A MOV E,A INX H MOV A,M ADC D MOV M,A INX H ; ((HL)) = LDDR TEXT TO SCAN PUSH H ; (S4) <- ADDR MOV A,E LXI D,-1 ; INITIALIZE CHR OFFSET COUNTER DCX H ; (HL) <- ADDR-1 ; ; SKIP OVER LEADING DELIMITER CHRS ENCL1: INX H INX D CMP M ; IF TEXT CHR = DELIM CHR JZ ENCL1 ; THEN LOOP AGAIN ; ; ELSE IMIT INR D DCR D MOV D,A ; (DE) <- NEW INDEX JM XLOO2 ; IF INCR > 0 MOV A,E SUB M ; THEN (A) <- INDEX - LIMIT MOV A,D INX H SBB M JMP XLOO3 XLOO2: MOV A,M ; ELSE (A) <- LIMIT - INDEX SUB E INX H MOV A,M SBB D ; ; IF (A) < 0 NON-DELIM CHR FOUND ; PUSH D ; OFFSET TO 1ST NON-DELIMITER CHAR PUSH B ; SAVE 'IP' MOV B,A ; (B) <- DELIM CHR MOV A,M ; IF 1ST NON-DELIM = NULL ANA A JNZ ENCL2 ; FOUND NULL (00), STOP THE SEARCH ; INX D ; CHARACTER FOLLOWING NULL POP B XLOO3: JM BRAN1 ; THEN LOOP AGAIN INX H ; ELSE DONE SHLD RPP ; DISCARD R1 & R2 INX B ; SKIP BRANCH OFFSET INX B JMP NEXT ; DB 87H ; (+LOOP) DB '(+LOOP' DB ')'+80H DW XLOOP-9 XPLOO: DW $+2 POP D ; (DE) <- INCR JMP XLOO1 ; DB 84H  ; GET BACK 'IP' PUSH D DCX D ; (S1) <- OFFSET TO NULL PUSH D JMP NEXT ; ELSE TEXT CONTAINS NON-DELIM & NON-NULL CHR ; ENCL2: MOV A,B ; (A) <- DELIM CHR INX H ; (HL) <- ADDR NEXT CHR INX D ; (DE) <- OFFSET TO NEXT CHR CMP M ; IF NEXT CHR; (DO) DB '(DO' DB ')'+80H DW XPLOO-0AH XDO: DW $+2 LHLD RPP ; (RP) <- (RP) - 4 DCX H DCX H DCX H DCX H SHLD RPP POP D ; (R1) <- (S1) = INIT INDEX MOV M,E INX H MOV M,D POP D ; (R2) <- (S2) = LIMIT INX H MOV M,E INX H M <> DELIM CHR JZ ENCL4 MOV A,M ; AND IF NEXT CHR <> NULL ANA A JNZ ENCL2 ; THEN CONTINUE SCAN ; ELSE CHARACTER = NULL (00) ; ENCL3: POP B ; GET BACK 'IP' PUSH D ; (S2) <- OFFSET TO NULL PUSH D ; (S1) <- OFFSET TO NULL JMP NEXT ; ELSE OV M,D JMP NEXT ; DB 81H ; I DB 'I'+80H DW XDO-7 IDO: DW $+2 ;(S1) <- (R1) , (R1) UNCHANGED LHLD RPP MOV E,M ; (DE) <- (R1) INX H MOV D,M PUSH D ; (S1) <- (DE) JMP NEXT ; DB 85H ; DIGIT DB 'DIGI' DB 'T'+80H DW IDO-4 DIGIT: DCHARACTER = DELIMITER CHARACTER ; ENCL4: POP B ; GET BACK 'IP' PUSH D ; (S2) <- OFFSET TO BYTE ; FOLLOWING TEXT INX D ; (S1) <- OFFSET TO 2 BYTES AFTER ; END OF WORD PUSH D JMP NEXT PAGE DB 84H ; EMIT DB 'EMI' DB 'T'+80H :      DW ENCL-0AH EMIT: DW DOCOL DW PEMIT DW ONE,OUTT DW PSTOR,SEMIS ; DB 83H ; KEY DB 'KE' DB 'Y'+80H DW EMIT-7 KEY: DW $+2 JMP PKEY ; DB 89H ; ?TERMINAL DB '?TERMINA' DB 'L'+80H DW KEY-6 QTERM: DW $+2 LXI H,0 JMP PQTER ; D DW ANDD-6 ORR: DW $+2 ; (S1) <- (S1) OR (S2) POP D POP H MOV A,E ORA L MOV L,A MOV A,D ORA H MOV H,A JMP HPUSH ; DB 83H ; XOR DB 'XO' DB 'R'+80H DW ORR-5 XORR: DW $+2 ; (S1) <- (S1) XOR (S2) POP D POP H MOV A,E XRA LB 82H ; CR DB 'C' DB 'R'+80H DW QTERM-0CH CR: DW DOCOL DW ZERO DW OUTT,STORE ; CLEAR CHAR COUNT DW PCR,SEMIS ; DB 85H ; CMOVE DB 'CMOV' DB 'E'+80H DW CR-5 CMOVE: DW $+2 MOV L,C ; (HL) <- (IP) MOV H,B POP B ; (BC) <- (S1) = #CHR MOV L,A MOV A,D XRA H MOV H,A JMP HPUSH ; DB 83H ; SP@ DB 'SP' DB '@'+80H DW XORR-6 SPAT: DW $+2 ;(S1) <- (SP) LXI H,0 DAD SP ; (HL) <- (SP) JMP HPUSH ; (S1) <- (HL) ; DB 83H ; STACK POINTER STORE DB 'SP' DB '!'+80H DW SS POP D ; (DE) <- (S2) = DEST ADDR XTHL ; (HL) <- (S3) = SOURCE ADDR ; ; (S1) <- (IP) JMP CMOV2 ; RETURN IF #CHRS = 0 CMOV1: MOV A,M ; ((DE)) <- ((HL)) INX H ; INC SOURCE ADDR STAX D INX D ; INC DEST ADDR DCX B ; DEC #CHRS CMOV2: MOV A,PAT-6 SPSTO: DW $+2 ;(SP) <- (S0) ( USER VARIABLE ) LHLD UP ; (HL) <- USER VAR BASE ADDR LXI D,6 DAD D ; (HL) <- S0 MOV E,M ; (DE) <- (S0) INX H MOV D,M XCHG SPHL ; (SP) <- (S0) JMP NEXT ; DB 83H ; RP@ DB 'RP' DB '@'+80H DW SPSB ORA C JNZ CMOV1 ; REPEAT IF #CHRS <> 0 POP B ; RESTORE (IP) FROM (S1) JMP NEXT ; DB 82H ; U* 16X16 UNSIGNED MULTIPLY DB 'U' ; AVG EXECUTION TIME = 994 CYCLES DB '*'+80H DW CMOVE-8 USTAR: DW $+2 POP D ; (DE) <- MPLIER POP H ; (HL) <-TO-6 RPAT: DW $+2 ;(S1) <- (RP) LHLD RPP JMP HPUSH ; DB 83H ; RETURN STACK POINTER STORE DB 'RP' DB '!'+80H DW RPAT-6 RPSTO: DW $+2 ;(RP) <- (R0) ( USER VARIABLE ) LHLD UP ; (HL) <- USER VARIABLE BASE ADDR LXI D,8 DAD D ; (HL) <- R0  MPCAND PUSH B ; SAVE IP MOV B,H MOV A,L ; (BA) <- MPCAND CALL MPYX ; (AHL)1 <- MPCAND.LB * MPLIER ; 1ST PARTIAL PRODUCT PUSH H ; SAVE (HL)1 MOV H,A MOV A,B MOV B,H ; SAVE (A)1 CALL MPYX ; (AHL)2 <- MPCAND.HB * MPLIER ; MOV E,M ; (DE) <- (R0) INX H MOV D,M XCHG SHLD RPP ; (RP) <- (R0) JMP NEXT ; DB 82H ; ;S DB ';' DB 'S'+80H DW RPSTO-6 SEMIS: DW $+2 ;(IP) <- (R1) LHLD RPP MOV C,M ; (BC) <- (R1) INX H MOV B,M INX H SHLD RPP ; (RP) <- (RP) +  2ND PARTIAL PRODUCT POP D ; (DE) <- (HL)1 MOV C,D ; (BC) <- (AH)1 ; FORM SUM OF PARTIALS: ; (AHL) 1 ; + (AHL) 2 ; -------- ; (AHLE) DAD B ; (HL) <- (HL)2 + (AH)1 ACI 0 ; (AHLE) <- (BA) * (DE) MOV D,L MOV L,H MOV H,A ; (HL2 JMP NEXT ; DB 85H ; LEAVE DB 'LEAV' DB 'E'+80H DW SEMIS-5 LEAVE: DW $+2 ;LIMIT <- INDEX LHLD RPP MOV E,M ; (DE) <- (R1) = INDEX INX H MOV D,M INX H MOV M,E ; (R2) <- (DE) = LIMIT INX H MOV M,D JMP NEXT ; DB 82H ; >R DB DE) <- MPLIER * MPCAND POP B ; RESTORE IP PUSH D ; (S2) <- PRODUCT.LW JMP HPUSH ; (S1) <- PRODUCT.HW ; ; MULTIPLY PRIMITIVE ; (AHL) <- (A) * (DE) ; #BITS = 24 8 16 MPYX: LXI H,0 ; (HL) <- 0 = PARTIAL PRODUCT.LW MVI C,8 ; LOOP COUNTER MPYX'>' DB 'R'+80H DW LEAVE-8 TOR: DW $+2 ;(R1) <- (S1) POP D ; (DE) <- (S1) LHLD RPP DCX H ; (RP) <- (RP) - 2 DCX H SHLD RPP MOV M,E ; ((HL)) <- (DE) INX H MOV M,D JMP NEXT ; DB 82H ; R> DB 'R' DB '>'+80H DW TOR-5 FROMR: DW $+1: DAD H ; LEFT SHIFT (AHL) 24 BITS RAL JNC MPYX2 ; IF NEXT MPLIER BIT = 1 DAD D ; THEN ADD MPCAND ACI 0 MPYX2: DCR C ; IF NOT LAST MPLIER BIT JNZ MPYX1 ; THEN LOOP AGAIN RET ; ELSE DONE ; DB 82H ; U/ DB 'U' DB '/'+80H DW USTAR-5 US2 ;(S1) <- (R1) LHLD RPP MOV E,M ; (DE) <- (R1) INX H MOV D,M INX H SHLD RPP ; (RP) <- (RP) + 2 PUSH D ; (S1) <- (DE) JMP NEXT ; DB 81H ; R DB 'R'+80H DW FROMR-5 RR: DW IDO+2 ; DB 82H ; 0= DB '0' DB '='+80H DW RR-4 ZEQU: DLAS: DW $+2 LXI H,4 DAD SP ; ((HL)) <- NUMERATOR.LW MOV E,M ; (DE) <- NUMER.LW MOV M,C ; SAVE IP ON STACK INX H MOV D,M MOV M,B POP B ; (BC) <- DENOMINATOR POP H ; (HL) <- NUMER.HW MOV A,L SUB C ; IF NUMER >= DENOM MOV A,H SBB B W $+2 POP H ; (HL) <- (S1) MOV A,L ORA H ; IF (HL) = 0 LXI H,0 ; THEN (HL) <- FALSE JNZ ZEQU1 INX H ; ELSE (HL) <- TRUE ZEQU1: JMP HPUSH ; (S1) <- (HL) ; DB 82H ; 0< DB '0' DB '<'+80H DW ZEQU-5 ZLESS: DW $+2 POP H ; (HL) <- (S1)  JC USLA1 LXI H,0FFFFH ; THEN OVERFLOW LXI D,0FFFFH ; SET REM & QUOT TO MAX JMP USLA7 USLA1: MVI A,16 ; LOOP COUNTER USLA2: DAD H ; LEFT SHIFT (HLDE) THRU CARRY RAL XCHG DAD H JNC USLA3 INX D ANA A USLA3: XCHG ; SHIFT DONE RAR ; REDAD H ; IF (HL) >= 0 LXI H,0 ; THEN (HL) <- FALSE JNC ZLES1 INX H ; ELSE (HL) <- TRUE ZLES1: JMP HPUSH ; (S1) <- (HL) ; DB 81H ; + DB '+'+80H DW ZLESS-5 PLUS: DW $+2 ;(S1) <- (S1) + (S2) POP D POP H DAD D JMP HPUSH ; DB 82H ; D+ (STORE 1ST CARRY PUSH PSW ; SAVE COUNTER JNC USLA4 ; IF CARRY = 1 MOV A,L ; THEN (HL) <- (HL) - (BC) SUB C MOV L,A MOV A,H SBB B MOV H,A JMP USLA5 USLA4: MOV A,L ; ELSE TRY (HL) <- (HL) - (BC) SUB C MOV L,A MOV A,H SBB B ; (HL) <-4-2) DB 'D' ; XLW XHW YLW YHW --- SLW SHW DB '+'+80H ; S4 S3 S2 S1 S2 S1 DW PLUS-4 DPLUS: DW $+2 LXI H,6 DAD SP ; ((HL)) = XLW MOV E,M ; (DE) = XLW MOV M,C ; SAVE IP ON STACK INX H MOV D,M MOV M,B POP B ; (BC) <- YHW  PARTIAL REMAINDER MOV H,A JNC USLA5 DAD B ; UNDERFLOW, RESTORE DCX D USLA5: INX D ; INC QUOT USLA6: POP PSW ; RESTORE COUNTER DCR A ; IF COUNTER > 0 JNZ USLA2 ; THEN LOOP AGAIN USLA7: POP B ; ELSE DONE, RESTORE IP PUSH H ; (S2) <- REMAIND POP H ; (HL) <- YLW DAD D XCHG ; (DE) <- YLW + XLW = SUM.LW POP H ; (HL) <- XHW MOV A,L ADC C MOV L,A ; (HL) <- YHW + XHW + CARRY MOV A,H ADC B MOV H,A POP B ; RESTORE IP PUSH D ; (S2) <- SUM.LW JMP HPUSH ; (S1) <- SUM.HW ; DB ER PUSH D ; (S1) <- QUOTIENT JMP NEXT ; DB 83H ; AND DB 'AN' DB 'D'+80H DW USLAS-5 ANDD: DW $+2 ; (S1) <- (S1) AND (S2) POP D POP H MOV A,E ANA L MOV L,A MOV A,D ANA H MOV H,A JMP HPUSH ; DB 82H ; OR DB 'O' DB 'R'+80H85H ; MINUS DB 'MINU' DB 'S'+80H DW DPLUS-5 MINUS: DW $+2 ;(S1) <- -(S1) ( 2'S COMPLEMENT ) POP H MOV A,L CMA MOV L,A MOV A,H CMA MOV H,A INX H JMP HPUSH ; DB 86H ; DMINUS DB 'DMINU' DB 'S'+80H DW MINUS-8 DMINU: DW $+2 ;     POP H ; (HL) <- HW POP D ; (DE) <- LW SUB A SUB E ; (DE) <- 0 - (DE) MOV E,A MVI A,0 SBB D MOV D,A MVI A,0 SBB L ; (HL) <- 0 - (HL) MOV L,A MVI A,0 SBB H MOV H,A PUSH D ; (S2) <- LW JMP HPUSH ; (S1) <- HW ; DB 84H ; OVER +80H DW NOOP-7 CON: DW DOCOL DW CREAT DW SMUDG DW COMMA DW PSCOD DOCON: INX D ; (DE) <- PFA XCHG MOV E,M ; (DE) <- (PFA) INX H MOV D,M PUSH D ; (S1) <- (PFA) JMP NEXT ; **************** ; * VARIABLE * ; **************** DB 'OVE' DB 'R'+80H DW DMINU-9 OVER: DW $+2 POP D POP H PUSH H JMP DPUSH ; DB 84H ; DROP DB 'DRO' DB 'P'+80H DW OVER-7 DROP: DW $+2 POP H JMP NEXT ; DB 84H ; SWAP DB 'SWA' DB 'P'+80H DW DROP-7 SWAP: DW $+2 POP H XTH; DB 88H ; VARIABLE DB 'VARIABL' DB 'E'+80H DW CON-0BH VAR: DW DOCOL DW CON DW PSCOD DOVAR: INX D ; (DE) <- PFA PUSH D ; (S1) <- PFA JMP NEXT ; ************ ; * USER * ; ************ ; DB 84H ; USER DB 'USE' DB 'R'+80H L JMP HPUSH ; DB 83H ; DUP DB 'DU' DB 'P'+80H DW SWAP-7 DUP: DW $+2 POP H PUSH H JMP HPUSH ; DB 84H ; 2DUP DB '2DU' DB 'P'+80H DW DUP-6 TDUP: DW $+2 POP H POP D PUSH D PUSH H JMP DPUSH ; DB 82H ; PLUS STORE DB '+' DW VAR-0BH USER: DW DOCOL DW CON DW PSCOD DOUSE: INX D ; (DE) <- PFA XCHG MOV E,M ; (DE) <- USER VARIABLE OFFSET MVI D,0 LHLD UP ; (HL) <- USER VARIABLE BASE ADDR DAD D ; (HL) <- (HL) + (DE) JMP HPUSH ; (S1) <- BASE + OFFSET ; ***** DB '!'+80H DW TDUP-7 PSTOR: DW $+2 ;((S1)) <- ((S1)) + (S2) POP H ; (HL) <- (S1) = ADDR POP D ; (DE) <- (S2) = INCR MOV A,M ; ((HL)) <- ((HL)) + (DE) ADD E MOV M,A INX H MOV A,M ADC D MOV M,A JMP NEXT ; DB 86H ; TOGGLE DB 'TO**** ; * 0 * ; ********* ; DB 81H ; 0 DB '0'+80H DW USER-7 ZERO: DW DOCON DW 0 ; ********* ; * 1 * ; ********* ; DB 81H ; 1 DB '1'+80H DW ZERO-4 ONE: DW DOCON DW 1 ; ********* ; * 2 * ; ********* ; DB 81H GGL' DB 'E'+80H DW PSTOR-5 TOGGL: DW $+2 ;((S2)) <- ((S2)) XOR (S1)LB POP D ; (E) <- BYTE MASK POP H ; (HL) <- ADDR MOV A,M XRA E MOV M,A ; (ADDR) <- (ADDR) XOR (E) JMP NEXT ; DB 81H ; @ DB '@'+80H DW TOGGL-9 AT: DW $+2 ;(S1) <- ((; 2 DB '2'+80H DW ONE-4 TWO: DW DOCON DW 2 ; ********* ; * 3 * ; ********* ; DB 81H ; 3 DB '3'+80H DW TWO-4 THREE: DW DOCON DW 3 ; ********** ; * BL * ; ********** ; DB 82H ; BL DB 'B' DB 'L'+80H DW THREE-4 S1)) POP H ; (HL) <- ADDR MOV E,M ; (DE) <- (ADDR) INX H MOV D,M PUSH D ; (S1) <- (DE) JMP NEXT ; DB 82H ; C@ DB 'C' DB '@'+80H DW AT-4 CAT: DW $+2 ;(S1) <- ((S1))LB POP H ; (HL) <- ADDR MOV L,M ; (HL) <- (ADDR)LB MVI H,0 JMP BL: DW DOCON DW 20H ; *********** ; * C/L * ; *********** ; DB 83H ; C/L ( CHARACTERS/LINE ) DB 'C/' DB 'L'+80H DW BL-5 CSLL: DW DOCON DW 64 ; ************* ; * FIRST * ; ************* ; DB 85H ; FIRST DB 'FIRS' DHPUSH ; DB 82H ; 2@ DB '2' DB '@'+80H DW CAT-5 TAT: DW $+2 POP H ; (HL) <- ADDR HW LXI D,2 DAD D ; (HL) <- ADDR LW MOV E,M ; (DE) <- LW INX H MOV D,M PUSH D ; (S2) <- LW LXI D,-3 ; (HL) <- ADDR HW DAD D MOV E,M ; (DE) <- HW B 'T'+80H DW CSLL-6 FIRST: DW DOCON DW BUF1 ; ************* ; * LIMIT * ; ************* ; DB 85H ; LIMIT DB 'LIMI' DB 'T'+80H DW FIRST-8 LIMIT: DW DOCON DW EM ; ************* ; * B/BUF * ; ************* ; DB 85H ; INX H MOV D,M PUSH D ; (S1) <- HW JMP NEXT ; DB 81H ; STORE DB '!'+80H DW TAT-5 STORE: DW $+2 ;((S1)) <- (S2) POP H ; (HL) <- (S1) = ADDR POP D ; (DE) <- (S2) = VALUE MOV M,E ; ((HL)) <- (DE) INX H MOV M,D JMP NEXT ; DB 82H ; CB/BUF ( BYTES/BUFFER ) DB 'B/BU' DB 'F'+80H DW LIMIT-8 BBUF: DW DOCON DW KBBUF ; ************* ; * B/SCR * ; ************* ; DB 85H ; B/SCR ( BUFFERS/SCREEN ) DB 'B/SC' DB 'R'+80H DW BBUF-8 BSCR: DW DOCON DW 400H/KBBUF  STORE DB 'C' DB '!'+80H DW STORE-4 CSTOR: DW $+2 ;((S1))LB <- (S2)LB POP H ; (HL) <- (S1) = ADDR POP D ; (DE) <- (S2) = BYTE MOV M,E ; ((HL))LB <- (E) JMP NEXT ; ********** ; * 2: * ; ********** ; DB 82H ; 2 STORE DB '2' D; *************** ; * +ORIGIN * ; *************** ; DB 87H ; +ORIGIN DB '+ORIGI' DB 'N'+80H DW BSCR-8 PORIG: DW DOCOL DW LIT DW ORIG DW PLUS DW SEMIS PAGE ; USER VARIABLES ; ; ; ********** ; * S0 * ; ********** ; DBB '!'+80H DW CSTOR-5 TSTOR: DW $+2 POP H ; (HL) <- ADDR POP D ; (DE) <- HW MOV M,E ; (ADDR) <- HW INX H MOV M,D INX H ; (HL) <- ADDR LW POP D ; (DE) <- LW MOV M,E ; (ADDR+2) <- LW INX H MOV M,D JMP NEXT ; ********* ; * :  82H ; S0 DB 'S' DB '0'+80H DW PORIG-0AH SZERO: DW DOUSE DW 6 ; ********** ; * R0 * ; ********** ; DB 82H ; R0 DB 'R' DB '0'+80H DW SZERO-5 RZERO: DW DOUSE DW 8 ; *********** ; * TIB * ; *********** ; DB 83H ; * ; ********* ; DB 0C1H ; : DB ':'+80H DW TSTOR-5 COLON: DW DOCOL DW QEXEC DW SCSP DW CURR DW AT DW CONT DW STORE DW CREAT DW RBRAC DW PSCOD DOCOL: LHLD RPP DCX H ; (R1) <- (IP) MOV M,B DCX H ; (RP) <- (RP) - 2 MOV M,C TIB DB 'TI' DB 'B'+80H DW RZERO-5 TIB: DW DOUSE DB 0AH ; ************* ; * WIDTH * ; ************* ; DB 85H ; WIDTH DB 'WIDT' DB 'H'+80H DW TIB-6 WIDTH: DW DOUSE DB 0CH ; *************** ; * WARNING * ; ********** SHLD RPP INX D ; (DE) <- CFA+2 = (W) MOV C,E ; (IP) <- (DE) = (W) MOV B,D JMP NEXT ; ********* ; * ; * ; ********* ; DB 0C1H ; ; DB ';'+80H DW COLON-4 SEMI: DW DOCOL DW QCSP DW COMP DW SEMIS DW SMUDG DW LBRAC DW SEMI***** ; DB 87H ; WARNING DB 'WARNIN' DB 'G'+80H DW WIDTH-8 WARN: DW DOUSE DB 0EH ; ************* ; * FENCE * ; ************* ; DB 85H ; FENCE DB 'FENC' DB 'E'+80H DW WARN-0AH FENCE: DW DOUSE DB 10H ; ********** ; * S ; ************ ; * NOOP * ; ************ ; DB 84H ; NOOP DB 'NOO' DB 'P'+80H DW SEMI-4 NOOP: DW $+2 NOP NOP JMP NEXT ; **************** ; * CONSTANT * ; **************** ; DB 88H ; CONSTANT DB 'CONSTAN' DB 'T' DP * ; ********** ; DB 82H ; DP DB 'D' DB 'P'+80H DW FENCE-8 DP: DW DOUSE DB 12H ; **************** ; * VOC-LINK * ; **************** ; DB 88H ; VOC-LINK DB 'VOC-LIN' DB 'K'+80H DW DP-5 VOCL: DW DOUSE DW 14H ; *<     ********** ; * BLK * ; *********** ; DB 83H ; BLK DB 'BL' DB 'K'+80H DW VOCL-0BH BLK: DW DOUSE DB 16H ; ********** ; * IN * ; ********** ; DB 82H ; IN DB 'I' DB 'N'+80H DW BLK-6 INN: DW DOUSE DB 18H ; ********* CALL SSUB ; (HL) <- X - Y LES1: INR H ; IF (HL) >= 0 DCR H JM LES2 LXI H,0 ; THEN X >= Y JMP HPUSH ; (S1) <- FALSE LES2: LXI H,1 ; ELSE X < Y JMP HPUSH ; (S1) <- TRUE ; ********** ; * U< * ; ********** ; DB 82H ; U< ( UNSIGNED < ** ; * OUT * ; *********** ; DB 83H ; OUT DB 'OU' DB 'T'+80H DW INN-5 OUTT: DW DOUSE DB 1AH ; *********** ; * SCR * ; *********** ; DB 83H ; SCR DB 'SC' DB 'R'+80H DW OUTT-6 SCR: DW DOUSE DB 1CH ; *************) DB 'U' DB '<'+80H DW LESS-4 ULESS: DW DOCOL,TDUP DW XORR,ZLESS DW ZBRAN,ULES1-$ ; IF DW DROP,ZLESS DW ZEQU DW BRAN,ULES2-$ ULES1: DW SUBB,ZLESS ; ELSE ULES2: DW SEMIS ; ENDIF ; ********* ; * > * ; ********* ; DB 81H ; > * ; * OFFSET * ; ************** ; DB 86H ; OFFSET DB 'OFFSE' DB 'T'+80H DW SCR-6 OFSET: DW DOUSE DB 1EH ; *************** ; * CONTEXT * ; *************** ; DB 87H ; CONTEXT DB 'CONTEX' DB 'T'+80H DW OFSET-9 CONT: DW D DB '>'+80H DW ULESS-5 GREAT: DW DOCOL DW SWAP DW LESS DW SEMIS ; DB 83H ; ROT DB 'RO' DB 'T'+80H DW GREAT-4 ROT: DW $+2 POP D POP H XTHL JMP DPUSH ; ************* ; * SPACE * ; ************* ; DB 85H ; SPACE DB OUSE DB 20H ; *************** ; * CURRENT * ; *************** ; DB 87H ; CURRENT DB 'CURREN' DB 'T'+80H DW CONT-0AH CURR: DW DOUSE DB 22H ; ************* ; * STATE * ; ************* ; DB 85H ; STATE DB 'STAT' DB ''SPAC' DB 'E'+80H DW ROT-6 SPACE: DW DOCOL DW BL DW EMIT DW SEMIS ; ************ ; * -DUP * ; ************ ; DB 84H ; -DUP DB '-DU' DB 'P'+80H DW SPACE-8 DDUP: DW DOCOL DW DUP DW ZBRAN ; IF DW DDUP1-$ DW DUP ; ENDIF E'+80H DW CURR-0AH STATE: DW DOUSE DB 24H ; ************ ; * BASE * ; ************ ; DB 84H ; BASE DB 'BAS' DB 'E'+80H DW STATE-8 BASE: DW DOUSE DB 26H ; DB 83H ; DPL DB 'DP' DB 'L'+80H DW BASE-7 DPL: DW DOUSE DB 28H DDUP1: DW SEMIS ; **************** ; * TRAVERSE * ; **************** ; DB 88H ; TRAVERSE DB 'TRAVERS' DB 'E'+80H DW DDUP-7 TRAV: DW DOCOL DW SWAP TRAV1: DW OVER ; BEGIN DW PLUS DW LIT DW 7FH DW OVER DW CAT DW LESS DW  ; *********** ; * FLD * ; *********** ; DB 83H ; FLD DB 'FL' DB 'D'+80H DW DPL-6 FLD: DW DOUSE DB 2AH ; *********** ; * CSP * ; *********** ; DB 83H ; CSP DB 'CS' DB 'P'+80H DW FLD-6 CSPP: DW DOUSE DB 2CH ZBRAN ; UNTIL DW TRAV1-$ DW SWAP DW DROP DW SEMIS ; ************** ; * LATEST * ; ************** ; DB 86H ; LATEST DB 'LATES' DB 'T'+80H DW TRAV-0BH LATES: DW DOCOL DW CURR DW AT DW AT DW SEMIS ; *********** ; *  ; ********** ; * R# * ; ********** ; DB 82H ; R# DB 'R' DB '#'+80H DW CSPP-6 RNUM: DW DOUSE DB 2EH ; *********** ; * HLD * ; *********** ; DB 83H ; HLD DB 'HL' DB 'D'+80H DW RNUM-5 HLD: DW DOUSE DW 30H ; ; END OF LFA * ; *********** ; DB 83H ; LFA DB 'LF' DB 'A'+80H DW LATES-9 LFA: DW DOCOL DW LIT DW 4 DW SUBB DW SEMIS ; *********** ; * CFA * ; *********** ; DB 83H ; CFA DB 'CF' DB 'A'+80H DW LFA-6 CFA: DW DOCOL DW TWO  USER VARIABLES ; DB 82H ; 1+ DB '1' DB '+'+80H DW HLD-6 ONEP: DW DOCOL DW ONE DW PLUS DW SEMIS ; ********** ; * 2+ * ; ********** ; DB 82H ; 2+ DB '2' DB '+'+80H DW ONEP-5 TWOP: DW DOCOL DW TWO DW PLUS DW SEMIS  DW SUBB DW SEMIS ; *********** ; * NFA * ; *********** ; DB 83H ; NFA DB 'NF' DB 'A'+80H DW CFA-6 NFA: DW DOCOL DW LIT DW 5 DW SUBB DW LIT DW -1 DW TRAV DW SEMIS ; *********** ; * PFA * ; *********** ; DB ; ************ ; * HERE * ; ************ ; DB 84H ; HERE DB 'HER' DB 'E'+80H DW TWOP-5 HERE: DW DOCOL DW DP DW AT DW SEMIS ; ************* ; * ALLOT * ; ************* ; DB 85H ; ALLOT DB 'ALLO' DB 'T'+80H DW HE 83H ; PFA DB 'PF' DB 'A'+80H DW NFA-6 PFA: DW DOCOL DW ONE DW TRAV DW LIT DW 5 DW PLUS DW SEMIS ; ************ ; * :CSP * ; ************ ; DB 84H ; STORE CSP DB '!CS' DB 'P'+80H DW PFA-6 SCSP: DW DOCOL DW SPAT DRE-7 ALLOT: DW DOCOL DW DP DW PSTOR DW SEMIS ; ********* ; * , * ; ********* ; DB 81H ; , DB ','+80H DW ALLOT-8 COMMA: DW DOCOL DW HERE DW STORE DW TWO DW ALLOT DW SEMIS ; ********** ; * C, * ; ********** ; W CSPP DW STORE DW SEMIS ; ************** ; * ?ERROR * ; ************** ; DB 86H ; ?ERROR DB '?ERRO' DB 'R'+80H DW SCSP-7 QERR: DW DOCOL DW SWAP DW ZBRAN ; IF DW QERR1-$ DW ERROR DW BRAN ; ELSE DW QERR2-$ QERR1: DW DRO DB 82H ; C, DB 'C' DB ','+80H DW COMMA-4 CCOMM: DW DOCOL DW HERE DW CSTOR DW ONE DW ALLOT DW SEMIS ; ; SUBROUTINE USED BY - AND < ; ; (HL) <- (HL) - (DE) SSUB: MOV A,L ; LB SUB E MOV L,A MOV A,H ; HB SBB D MOV H,A RET P ; ENDIF QERR2: DW SEMIS ; ************* ; * ?COMP * ; ************* ; DB 85H ; ?COMP DB '?COM' DB 'P'+80H DW QERR-9 QCOMP: DW DOCOL DW STATE DW AT DW ZEQU DW LIT DW 11H DW QERR DW SEMIS ; ************* ; * ?EXE ; ********* ; * - * ; ********* ; DB 81H ; - DB '-'+80H DW CCOMM-5 SUBB: DW $+2 POP D ; (DE) <- (S1) = Y POP H ; (HL) <- (S2) = X CALL SSUB JMP HPUSH ; (S1) <- X - Y ; ********* ; * = * ; ********* ; DB 81H ; = DB 'C * ; ************* ; DB 85H ; ?EXEC DB '?EXE' DB 'C'+80H DW QCOMP-8 QEXEC: DW DOCOL DW STATE DW AT DW LIT,12H DW QERR DW SEMIS ; ************** ; * ?PAIRS * ; ************** ; DB 86H ; ?PAIRS DB '?PAIR' DB 'S'+80H ='+80H DW SUBB-4 EQUAL: DW DOCOL DW SUBB DW ZEQU DW SEMIS ; DB 81H ; < DB '<'+80H ; X < Y DW EQUAL-4 ; S2 S1 LESS: DW $+2 POP D ; (DE) <- (S1) = Y POP H ; (HL) <- (S2) = X MOV A,D ; IF X & Y HAVE SAME SIGNS XRA H JM LES1  DW QEXEC-8 QPAIR: DW DOCOL DW SUBB DW LIT DW 13H DW QERR DW SEMIS ; ************ ; * ?CSP * ; ************ ; DB 84H ; ?CSP DB '?CS' DB 'P'+80H DW QPAIR-9 QCSP: DW DOCOL DW SPAT DW CSPP DW AT DW SUBB DW LIT DW 1=     4H DW QERR DW SEMIS ; **************** ; * ?LOADING * ; **************** ; DB 88H ; ?LOADING DB '?LOADIN' DB 'G'+80H DW QCSP-7 QLOAD: DW DOCOL DW BLK DW AT DW ZEQU DW LIT,16H DW QERR DW SEMIS ; *************** ; * * ; ************ ; DB 84H ; (.") DB '(."' DB ')'+80H DW DTRAI-0CH PDOTQ: DW DOCOL DW RR DW COUNT DW DUP DW ONEP DW FROMR DW PLUS DW TOR DW TYPE DW SEMIS ; ********* ; * . * ; ********* ; DB 0C2H ; ." DB '.'  COMPILE * ; *************** ; DB 87H ; COMPILE DB 'COMPIL' DB 'E'+80H DW QLOAD-0BH COMP: DW DOCOL DW QCOMP DW FROMR DW DUP DW TWOP DW TOR DW AT DW COMMA DW SEMIS ; ********* ; * [ * ; ********* ; DB 0C1H ; [  DB '"'+80H DW PDOTQ-7 DOTQ: DW DOCOL DW LIT DW 22H DW STATE DW AT DW ZBRAN ; IF DW DOTQ1-$ DW COMP DW PDOTQ DW WORD DW HERE DW CAT DW ONEP DW ALLOT DW BRAN ; ELSE DW DOTQ2-$ DOTQ1: DW WORD DW HERE DW COUNT DW TYPE ;DB '['+80H DW COMP-0AH LBRAC: DW DOCOL DW ZERO DW STATE DW STORE DW SEMIS ; ********* ; * ] * ; ********* ; DB 81H ; ] DB ']'+80H DW LBRAC-4 RBRAC: DW DOCOL DW LIT,0C0H DW STATE,STORE DW SEMIS ; ************** ; *  ENDIF DOTQ2: DW SEMIS ; ************** ; * EXPECT * ; ************** ; DB 86H ; EXPECT DB 'EXPEC' DB 'T'+80H DW DOTQ-5 EXPEC: DW DOCOL DW OVER DW PLUS DW OVER DW XDO ; DO EXPE1: DW KEY DW DUP DW LIT DW 0EH DW PORIG  SMUDGE * ; ************** ; DB 86H ; SMUDGE DB 'SMUDG' DB 'E'+80H DW RBRAC-4 SMUDG: DW DOCOL DW LATES DW LIT DW 20H DW TOGGL DW SEMIS ; *********** ; * HEX * ; *********** ; DB 83H ; HEX DB 'HE' DB 'X'+80H DW SM DW AT DW EQUAL DW ZBRAN ; IF DW EXPE2-$ DW DROP DW DUP DW IDO DW EQUAL DW DUP DW FROMR DW TWO DW SUBB DW PLUS DW TOR DW ZBRAN ; IF DW EXPE6-$ DW LIT DW BELL DW BRAN ; ELSE DW EXPE7-$ EXPE6: DW LIT DW BSOUT ; ENDIF UDG-9 HEX: DW DOCOL DW LIT DW 10H DW BASE DW STORE DW SEMIS ; *************** ; * DECIMAL * ; *************** ; DB 87H ; DECIMAL DB 'DECIMA' DB 'L'+80H DW HEX-6 DEC: DW DOCOL DW LIT DW 0AH DW BASE DW STORE DW SEMIS EXPE7: DW BRAN ; ELSE DW EXPE3-$ EXPE2: DW DUP DW LIT DW 0DH DW EQUAL DW ZBRAN ; IF DW EXPE4-$ DW LEAVE DW DROP DW BL DW ZERO DW BRAN ; ELSE DW EXPE5-$ EXPE4: DW DUP ; ENDIF EXPE5: DW IDO DW CSTOR DW ZERO DW IDO DW ONEP  ; *************** ; * (;CODE) * ; *************** ; DB 87H ; (;CODE) DB '(;CODE' DB ')'+80H DW DEC-0AH PSCOD: DW DOCOL DW FROMR DW LATES DW PFA DW CFA DW STORE DW SEMIS ; ************* ; * ;CODE * ; ************ DW STORE ; ENDIF EXPE3: DW EMIT DW XLOOP ; LOOP DW EXPE1-$ DW DROP DW SEMIS ; ************* ; * QUERY * ; ************* ; DB 85H ; QUERY DB 'QUER' DB 'Y'+80H DW EXPEC-9 QUERY: DW DOCOL DW TIB DW AT DW LIT DW 50H DW* ; DB 0C5H ; ;CODE DB ';COD' DB 'E'+80H DW PSCOD-0AH SEMIC: DW DOCOL DW QCSP DW COMP DW PSCOD DW LBRAC SEMI1: DW NOOP ; ( ASSEMBLER ) DW SEMIS ; *************** ; * * ; ************* ; DB 85H ; DOES> DB 'DOES' DB '>'+80H DW BUILD-0AH DOES: DW DOCOL DW FROMR DW LATES DW PFA DW STORE DW; GET NEXT DISK BLOCK DW ZERO,INN DW STORE DW BRAN DW NULL3-$ NULL6: DW BLK DW AT DW ZBRAN ; IF DW NULL1-$ DW ONE DW BLK DW PSTOR DW ZERO DW INN DW STORE DW BLK DW AT DW BSCR DW ONE DW SUBB DW ANDD DW ZEQU DW ZBRA PSCOD DODOE: LHLD RPP ; (HL) <- (RP) DCX H MOV M,B ; (R1) <- (IP) = PFA = (SUBSTITUTE CFA) DCX H MOV M,C SHLD RPP ; (RP) <- (RP) - 2 INX D ; (DE) <- PFA = (SUBSTITUTE CFA) XCHG MOV C,M ; (IP) <- (SUBSTITUTE CFA) INX H MOV B,M INX H N ; IF DW NULL2-$ DW QEXEC DW FROMR DW DROP ; ENDIF NULL2: DW BRAN ; ELSE DW NULL3-$ NULL1: DW FROMR DW DROP ; ENDIF NULL3: DW SEMIS ; ************ ; * FILL * ; ************ ; DB 84H ; FILL DB 'FIL' DB 'L'+80H DW NULL-4  JMP HPUSH ; (S1) <- PFA+2 = SUBSTITUTE PFA ; ************* ; * COUNT * ; ************* ; DB 85H ; COUNT DB 'COUN' DB 'T'+80H DW DOES-8 COUNT: DW DOCOL DW DUP DW ONEP DW SWAP DW CAT DW SEMIS PAGE ; ************ ; * FILL: DW $+2 MOV L,C MOV H,B POP D POP B XTHL XCHG FILL1: MOV A,B ; BEGIN ORA C JZ FILL2 ; WHILE MOV A,L STAX D INX D DCX B JMP FILL1 ; REPEAT FILL2: POP B JMP NEXT ; ************* ; * ERASE * ; ************* ; D TYPE * ; ************ ; DB 84H ; TYPE DB 'TYP' DB 'E'+80H DW COUNT-8 TYPE: DW DOCOL DW DDUP DW ZBRAN ; IF DW TYPE1-$ DW OVER DW PLUS DW SWAP DW XDO ; DO TYPE2: DW IDO DW CAT DW EMIT DW XLOOP ; LOOP DW TYPE2-$ DW BRAN B 85H ; ERASE DB 'ERAS' DB 'E'+80H DW FILL-7 ERASEE: DW DOCOL DW ZERO DW FILL DW SEMIS ; ************** ; * BLANKS * ; ************** ; DB 86H ; BLANKS DB 'BLANK' DB 'S'+80H DW ERASEE-8 BLANK: DW DOCOL DW BL DW FILL ; ELSE DW TYPE3-$ TYPE1: DW DROP ; ENDIF TYPE3: DW SEMIS PAGE ; ***************** ; * -TRAILING * ; ***************** ; DB 89H ; -TRAILING DB '-TRAILIN' DB 'G'+80H DW TYPE-7 DTRAI: DW DOCOL DW DUP DW ZERO DW XDO ; DO DTRA1: DW SEMIS ; ************ ; * HOLD * ; ************ ; DB 84H ; HOLD DB 'HOL' DB 'D'+80H DW BLANK-9 HOLD: DW DOCOL DW LIT DW -1 DW HLD DW PSTOR DW HLD DW AT DW CSTOR DW SEMIS ; *********** ; * PAD * ; **********DW OVER DW OVER DW PLUS DW ONE DW SUBB DW CAT DW BL DW SUBB DW ZBRAN ; IF DW DTRA2-$ DW LEAVE DW BRAN ; ELSE DW DTRA3-$ DTRA2: DW ONE DW SUBB ; ENDIF DTRA3: DW XLOOP ; LOOP DW DTRA1-$ DW SEMIS ; ************ ; * (.")* ; DB 83H ; PAD DB 'PA' DB 'D'+80H DW HOLD-7 PAD: DW DOCOL DW HERE DW LIT DW 44H DW PLUS DW SEMIS ; END OF BASIC RELOCATABLE MODULE END >      TITLE '8080 FIG-FORTH 4THCOMP (09/18/84)' ;**************************************************************** ; ; ; 8080 FIG-FORTH 4THCOMP ; ; ; ; CONCEIVED BY NICK AVDONIN 09/18/84 ; ; UPDATED: 09/18/84 ; ; ; TLOA' DB 'D'+80H DW FPTR-7 QTLOAD: DW DOVAR DW 0 ; ; ; ************** ; * DBUFF1 * ; ************** DB 86H ; DBUFF1 ; ( DATA BUFFER #1 ) DB 'DBUFF' DB '1'+80H DW QTLOAD-9 DBUFF1: DW DOCON DW 29178 ; ; ************** ; * ; HI LEVEL CODE AND CP/M INTERFACE ; ; ; ;**************************************************************** ; ; RELEASE & VERSION NUMBERS ; FIGREL EQU 4 ; FIG RELEASE # FIGREV EQU 1 ; FIG REVISION # ;USRVER EQU 0 ; USER VERSION # ; ; DBUFF2 * ; ************** DB 86H ; DBUFF2 ; ( DATA BUFFER #2 ) DB 'DBUFF' DB '2'+80H DW DBUFF1-9 DBUFF2: DW DOCON DW 30206 ; ; ************ ; * WORD * ; ************ ; DB 84H ; WORD--MODIFIED FOR FORTH COMP BY NAA DB 'WO ALL PUBLICATIONS OF THE FORTH INTEREST GROUP ; ARE PUBLIC DOMAIN. THEY MAY BE FURTHER ; DISTRIBUTED BY THE INCLUSION OF THIS CREDIT ; NOTICE: ; ; THIS PUBLICATION HAS BEEN MADE AVAILABLE BY THE ; FORTH INTEREST GROUP ; P. O. BOX 1105 R' DB 'D'+80H DW DBUFF2-9 WORD: DW DOCOL DW QTLOAD DW AT DW ZEQU DW ZBRAN ; IF DW WORD4-$ ; DW BLK ; FOR FORTH COMP, ASSUME ONLY BLOCK 0 ; DW AT ; DW ZBRAN ; IF ; DW WORD1-$ ; DW BLK ; DW AT ; DW BLOCK ; DW BRAN ; ELSE ; DW WORD2-$; SAN CARLOS, CA 94070 ; PAGE ; GLOBAL SYMBOLS DEFINED GLOBAL CLD ; COLD START GLOBAL WRM ; WARM START GLOBAL TASK ; TOP MOST WORD IN FORTH VOC GLOBAL INITDP ; INITIAL DICTIONARY POINTER GLOBAL FORTH ; INITIAL VOCABULARY LIN WORD1: DW TIB DW AT ; ENDIF WORD3: DW BRAN ; ELSE DW WORD2-$ WORD4: DW DBUFF2 ; BUFFER 2, COMPILE RAM WORD2: DW INN DW AT DW PLUS DW SWAP DW ENCL DW HERE DW LIT DW 22H DW BLANK DW INN DW PSTOR DW OVER DW SUBB DW TOR DW K GLOBAL PEMIT ; PRINTER EMIT GLOBAL PKEY ; KEYBOARD GLOBAL PQTER GLOBAL PCR GLOBAL CREAT ; CREATE GLOBAL ERROR ; ERROR PROCESSING GLOBAL WORD GLOBAL QTLOAD GLOBAL NXTBLK ; EXTRN SYMBOLS REQUIRED EXTRN AT,ANDD,ALLOT EXTRN BASE,RR DW HERE DW CSTOR DW PLUS DW HERE DW ONEP DW FROMR DW CMOVE DW SEMIS ; ************ ; * MON * ; ************ ; DB 83H ; MON--RETURN TO DEBUG MONITOR DB 'MO' DB 'N'+80H DW WORD-7 MON: DW $+2 ; CODE DEFINITION JMP 38H BLK,BUILD,BRAN,BLANK,BL EXTRN CAT,CSLL,COMP,CURR,COMMA,CFA,CSTOR,CMOVE,CR,COUNT,CONT EXTRN DIGIT,DEC,DOES,DODOE,DMINU,DPLUS,DPL,DOVAR EXTRN DOCON,DP0,DDUP,DP,DTRAI,DPUSH,DOCOL,DROP,DUP EXTRN ENCL,EQUAL,EXEC EXTRN FROMR,FILL,FENCE EXTRN GREAT  JMP NEXT ; **************** ; * WARN * ; **************** ; DB 84H ; ISSUE WARNING OF UNDEFINED WORD DB 'WAR' DB 'N'+80H DW MON-6 WARNU: DW DOCOL DW CR DW HERE DW COUNT DW TYPE DW PDOTQ DB 33,' ? NOT DEFINED -- CONTIEXTRN HERE,HLD,HOLD,HPUSH EXTRN INN,IDO EXTRN LIT,LBRAC,LFA,LEAVE,LESS,LATES EXTRN MINUS EXTRN NEXT,NFA,NOOP EXTRN ORIG,ORR,OUTT,OVER,ONE,ONEP EXTRN PLUS,PAD,PFA,PSTOR,PDOTQ,PFIND EXTRN QERR,QUERY,QCOMP,QPAIR,QTERM EXTRN RR,ROT,RPP,RPSTO NUING... ' DW DROP,ZERO DW SEMIS ; ; ; **************** ; * WHERE * ; **************** ; DB 85H ; WHERE, PRINT COMPILIATION DB 'WHER' DB 'E'+80H DW WARNU-7 ; WHERE: DW DOCOL DW HERE DW ONEP DW CAT DW LIT DW 58 ; COLON EXTRN SWAP,SZERO,SPSTO,SPAT,STATE,SEMIS,STORE,SUBB,SEMIS,SPACE EXTRN TIB,TWO,TWOP,THREE,TDUP,TOR,TOGGL,TYPE EXTRN USTAR,UP,ULESS,USLAS EXTRN VOCL EXTRN WARN,WIDTH EXTRN XDO,XPLOO,XORR,XLOOP EXTRN ZEQU,ZLESS,ZBRAN,ZERO ; ASCII CHARACTERS US DW EQUAL DW ZBRAN DW WHERE1-$ DW CR DW PDOTQ DB 14,'COMPILING --> ' DW DBUFF2 DW INN,AT DW PLUS DW LIT DW 32 DW ENCL DW DROP,SWAP DW DROP,TYPE DW SPACE WHERE1: DW SEMIS ; ; ; **************** ; * SP.FIND * ; ********ED ; ABL EQU 20H ; SPACE ACR EQU 0DH ; CARRIAGE RETURN ADOT EQU 02EH ; PERIOD BELL EQU 07H ; (^G) BSIN EQU 08H ; INPUT BACKSPACE CHR = (^H)--MOD NAA BSOUT EQU 08H ; OUTPUT BACKSPACE (^H) DLE EQU 10H ; (^P) LF EQU 0AH ; LINE FEED FF EQU 0CH ; FORM******** ; DB 87H ; SPECIAL FIND, FOR TLOAD DB 'SP.FIN' DB 'D'+80H DW WHERE-8 ; SPFIND: DW DOCOL DW BL DW WORD DW WHERE DW HERE,CONT DW AT,AT DW PFIND DW DUP DW ZEQU DW ZBRAN ; IF DW SPFIN1-$ DW DROP DW HERE DW LATES  FEED (^L) ; ; MEMORY ALLOCATION ; EM EQU 7A00H ; TOP OF MEMORY + 1 = LIMIT NSCR EQU 2 ; NUMBER OF 1024 BYTE SCREENS KBBUF EQU 1024 ; DATA BYTES PER DISK BUFFER US EQU 40H ; USER VARIABLES SPACE RTS EQU 0A0H ; RETURN STACK & TERM BUFF SPACE ; DW PFIND ; ENDIF SPFIN1: DW SEMIS ; ; **************** ; * (NUMBER) * ; **************** ; DB 88H ; (NUMBER) DB '(NUMBER' DB ')'+80H DW SPFIND-10 PNUMB: DW DOCOL PNUM1: DW ONEP ; BEGIN DW DUP DW TOR DW CAT DW BASE DW AT DW DCO EQU KBBUF+4 ; DISK BUFFER + 2 HEADER + 2 TAIL NBUF EQU NSCR*400H/KBBUF ; NUMBER OF BUFFERS BUF1 EQU EM-CO*NBUF ; ADDR FIRST DISK BUFFER INITR0 EQU BUF1-US ; (R0) INITS0 EQU INITR0-RTS ; (S0) ; PAGE ;*********************************************IGIT DW ZBRAN ; WHILE DW PNUM2-$ DW SWAP DW BASE DW AT DW USTAR DW DROP DW ROT DW BASE DW AT DW USTAR DW DPLUS DW DPL DW AT DW ONEP DW ZBRAN ; IF DW PNUM3-$ DW ONE DW DPL DW PSTOR ; ENDIF PNUM3: DW FROMR DW BRAN ;******************* ; ; ; START OF FORTH COMP SPECIAL WORDS ; ; ; ; CONCEIVED BY NICK AVDONIN 9/18/84 ; ; UPDATED: 9/18/84 ; ; ; ;**************************************************************** ; ************* REPEAT DW PNUM1-$ PNUM2: DW FROMR DW SEMIS ; ************** ; * NUMBER * ; ************** ; DB 86H ; NUMBER DB 'NUMBE' DB 'R'+80H DW PNUMB-0BH NUMB: DW DOCOL DW ZERO DW ZERO DW ROT DW DUP DW ONEP DW CAT DW LIT DW  ; * FPTR * ; ************* ; DB 84H ; FPTR ; ( FILE POINTER OF TLOAD ) DB 'FPT' DB 'R'+80H DW PAD-6 FPTR: DW DOVAR DW 0 ; ************** ; * ?TLOAD * ; ************** DB 86H ; ?TLOAD ; ( ARE WE TLOADING? ) DB '?2DH DW EQUAL DW DUP DW TOR DW PLUS DW LIT DW -1 NUMB1: DW DPL ; BEGIN DW STORE DW PNUMB DW DUP DW CAT DW BL DW SUBB DW ZBRAN ; WHILE DW NUMB2-$ DW DUP DW CAT DW LIT DW 2EH DW SUBB DW ZERO DW QERR DW ZERO DW BR?     AN ; REPEAT DW NUMB1-$ NUMB2: DW DROP DW FROMR DW ZBRAN ; IF DW NUMB3-$ DW DMINU ; ENDIF NUMB3: DW SEMIS ; ************* ; * -FIND * ; ************* ; DB 85H ; -FIND (0-3) SUCCESS DB '-FIN' ; (0-1) FAILURE DB 'D'+80H DW NUMBE,WARN DW STORE DW ERROR DW SEMIS ; ************* ; * ERROR * ; ************* ; DB 85H ; ERROR DB 'ERRO' DB 'R'+80H DW PABOR-0AH ERROR: DW DOCOL DW WARN DW AT DW ZLESS DW ZBRAN ; IF DW ERRO1-$ DW PABOR ; ENDIF ERRO1:-9 DFIND: DW DOCOL DW BL DW WORD DW HERE DW CONT DW AT DW AT DW PFIND DW DUP DW ZEQU DW ZBRAN ; IF DW DFIN1-$ DW DROP DW HERE DW LATES DW PFIND ; ENDIF DFIN1: DW SEMIS ; **************** ; * SP.NUMBER * ; *********** DW HERE DW COUNT DW TYPE DW PDOTQ DB 2 DB '? ' DW MESS DW SPSTO ERRO2: DW QUIT ; *********** ; * ID. * ; *********** ; DB 83H DB 'ID' DB '.'+80H DW ERROR-8 IDDOT: DW DOCOL DW PAD DW LIT DW 20H DW LIT DW 5FH ***** ; DB 89H ; SPECIAL NUMBER PROCESS, FOR TLOAD DB 'SP.NUMBE' DB 'R'+80H DW DFIND-8 ; SPNUMB: DW DOCOL DW ZERO,ZERO DW ROT,DUP DW ONEP,CAT DW LIT,45 DW EQUAL DW DUP,TOR DW PLUS,PNUMB DW SWAP,DROP DW CAT DW BL,SUBB DW ZBRDW FILL DW DUP DW PFA DW LFA DW OVER DW SUBB DW PAD DW SWAP DW CMOVE DW PAD DW COUNT DW LIT DW 1FH DW ANDD DW TYPE DW SPACE DW SEMIS ; ************** ; * CREATE * ; ************** ; DB 86H DB 'CREAT' DB 'E'AN DW SPNUM1-$ DW WARNU SPNUM1: DW FROMR DW ZBRAN DW SPNUM2-$ DW MINUS SPNUM2: DW SEMIS ; ***************** ; * TINTERPRET * ; ***************** ; DB 8AH ; FOR TLOADING DB 'TINTERPRE' DB 'T'+80H DW SPNUMB-12 TINTER: DW D+80H DW IDDOT-6 CREAT: DW DOCOL DW DFIND DW ZBRAN ; IF DW CREA1-$ DW DROP DW NFA DW IDDOT DW LIT,4 DW MESS DW SPACE ; ENDIF CREA1: DW HERE DW DUP DW CAT DW WIDTH DW AT DW MIN DW ONEP DW ALLOT DW DUP DW LIT,0A0H DW OCOL TINTE1: DW SPFIND ; BEGIN DW ZBRAN ; IF DW TINTE2-$ DW STATE DW NOOP DW AT DW LESS DW ZBRAN ; IF DW TINTE3-$ DW CFA DW COMMA DW BRAN ; ELSE DW TINTE4-$ TINTE3: DW CFA DW EXEC ; ENDIF TINTE4: DW QSTAC DW BRAN ; ELSE DW TOGGL DW HERE DW ONE DW SUBB DW LIT,80H DW TOGGL DW LATES DW COMMA DW CURR DW AT DW STORE DW HERE DW TWOP DW COMMA DW SEMIS ; ***************** ; * [COMPILE] * ; ***************** ; DB 0C9H DB '[COMPILE' DB ']'+8TINTE5-$ TINTE2: DW HERE DW SPNUMB DW LITER TINTE7: DW QSTAC ; ENDIF TINTE5: DW BRAN ; AGAIN--NOTE: 'X' = NULL WORD EXITS LOOP DW TINTE1-$ ; ***************** ; * SCAN/AHEAD * ; ***************** ; DB 8AH ; PREPARE FOR COMPILE DB 0H DW CREAT-9 BCOMP: DW DOCOL DW DFIND DW ZEQU DW ZERO DW QERR DW DROP DW CFA DW COMMA DW SEMIS ; *************** ; * LITERAL * ; *************** ; DB 0C7H DB 'LITERA' DB 'L'+80H DW BCOMP-0CH LITER: DW DOCOL DW STA'SCAN/AHEA' DB 'D'+80H DW TINTER-13 SCAN: DW DOCOL DW DBUFF2 DW LIT,600 DW OVER,PLUS DW SWAP DW XDO SCAN1: DW IDO,CAT DW LIT,127 DW ANDD DW DUP DW BL,LESS DW ZBRAN DW SCAN2-$ DW DROP DW BL ; INSERT BLANK SCAN2: DW IDO,CSTOTE DW AT DW ZBRAN ; IF DW LITE1-$ DW COMP DW LIT DW COMMA ; ENDIF LITE1: DW SEMIS ; **************** ; * DLITERAL * ; **************** ; DB 0C8H DB 'DLITERA' DB 'L'+80H DW LITER-0AH DLITE: DW DOCOL DW STATE DW AT DW R DW XLOOP DW SCAN1-$ DW DBUFF2 DW LIT,600 DW PLUS DW LIT,80 DW OVER,PLUS DW SWAP DW XDO SCAN4: DW IDO DW CAT DW LIT,127 DW ANDD DW DUP DW LIT,20 DW LESS DW ZBRAN DW SCAN5-$ DW DROP DW ZERO,ZERO DW IDO ; INSERT ENDZBRAN ; IF DW DLIT1-$ DW SWAP DW LITER DW LITER ; ENDIF DLIT1: DW SEMIS ; ************** ; * ?STACK * ; ************** ; DB 86H DB '?STAC' DB 'K'+80H DW DLITE-0BH QSTAC: DW DOCOL DW SPAT DW SZERO DW AT DW SWAP DW ULE COMPILATION DW ONEP,CSTOR DW IDO DW DBUFF2 DW SUBB DW FPTR,PSTOR DW LEAVE SCAN5: DW IDO DW CSTOR DW XLOOP,SCAN4-$ DW SEMIS ; ***************** ; * NXT.BLK * ; ***************** ; DB 87H ; FETCH NEXT DISK BLOCK DB 'SS DW ONE DW QERR DW SPAT DW HERE DW LIT DW 80H DW PLUS DW ULESS DW LIT DW 7 DW QERR DW SEMIS ; ***************** ; * INTERPRET * ; ***************** ; DB 89H DB 'INTERPRE' DB 'T'+80H DW QSTAC-9 INTER: DW DOCOL NXT.BL' DB 'K'+80H DW SCAN-13 NXTBLK: DW DOCOL DW QTLOAD,AT DW ZBRAN DW NXTBL1-$ DW FPTR,AT ; WE ARE TLOADING DW LIT,768 DW VMTRAM DW SCAN DW ZERO DW INN,STORE DW BRAN DW NXTBL2-$ NXTBL1: DW ONE DW BLK,PSTOR NXTBL2: DW SEMIS INTE1: DW DFIND ; BEGIN DW ZBRAN ; IF DW INTE2-$ DW STATE DW AT DW LESS DW ZBRAN ; IF DW INTE3-$ DW CFA DW COMMA DW BRAN ; ELSE DW INTE4-$ INTE3: DW CFA DW EXEC ; ENDIF INTE4: DW QSTAC DW BRAN ; ELSE DW INTE5-$ INTE2: DW HER ; ***************** ; * TLOAD * ; ***************** ; DB 85H ; BEGIN SPECIAL INTERPRET DB 'TLOA' DB 'D'+80H DW NXTBLK-10 TLOAD: DW DOCOL DW LIT,-1 DW WARN,STORE DW KEYTO DW POPEN DW ZERO DW FPTR,STORE DW INN,AT DW E DW NUMB DW DPL DW AT DW ONEP DW ZBRAN ; IF DW INTE6-$ DW DLITE DW BRAN ; ELSE DW INTE7-$ INTE6: DW DROP DW LITER ; ENDIF INTE7: DW QSTAC ; ENDIF INTE5: DW BRAN ; AGAIN DW INTE1-$ ; ***************** ; * IMMEDIATE * ; *TOR DW ZERO DW INN,STORE DW ONE,QTLOAD DW STORE DW NXTBLK DW TINTER DW FROMR DW INN,STORE DW CR DW PDOTQ DB 20,'END TEXT COMPILATION' DW CR DW FCB DW ONEP DW LIT,35 DW ZERO,FILL DW ZERO,QTLOAD DW STORE DW ONE,WARN DW**************** ; DB 89H DB 'IMMEDIAT' DB 'E'+80H DW INTER-0CH IMMED: DW DOCOL DW LATES DW LIT DW 40H DW TOGGL DW SEMIS ; ****************** ; * VOCABULARY * ; ****************** ; DB 8AH DB 'VOCABULAR' DB 'Y'+80H D STORE DW SEMIS ; *************** ; * (ABORT) * ; *************** ; DB 87H ; (ABORT) DB '(ABORT' DB ')'+80H DW TLOAD-8 PABOR: DW DOCOL ; USER ABORT DW ZERO,QTLOAD DW STORE DW CR DW PDOTQ DB 17,'ABORTING COMPILE ' DW ONW IMMED-0CH VOCAB: DW DOCOL DW BUILD DW LIT DW 0A081H DW COMMA DW CURR DW AT DW CFA DW COMMA DW HERE DW VOCL DW AT DW COMMA DW VOCL DW STORE DW DOES DOVOC: DW TWOP DW CONT DW STORE DW SEMIS ; ************* ; * @     FORTH * ; ************* ; DB 0C5H DB 'FORT' DB 'H'+80H DW VOCAB-0DH FORTH: DW DODOE DW DOVOC DW 0A081H DW TASK-7 ; COLD START VALUE ONLY ; CHANGED EACH TIME A DEF IS APPENDED ; TO THE FORTH VOCABULARY DW 0 ; END OF VOCABULARYTDUP DW XORR DW TOR DW ABS DW SWAP DW ABS DW USTAR DW FROMR DW DPM DW SEMIS ; ********** ; * M/ * ; ********** ; DB 82H DB 'M' DB '/'+80H DW MSTAR-5 MSLAS: DW DOCOL DW OVER DW TOR DW TOR DW DABS DW RR DW A LIST ; ******************* ; * DEFINITIONS * ; ******************* ; DB 8BH DB 'DEFINITION' DB 'S'+80H DW FORTH-8 DEFIN: DW DOCOL DW CONT DW AT DW CURR DW STORE DW SEMIS ; ********* ; * ( * ; ********* ; DB 0C1BS DW USLAS DW FROMR DW RR DW XORR DW PM DW SWAP DW FROMR DW PM DW SWAP DW SEMIS ; ********* ; * * * ; ********* ; DB 81H DB '*'+80H DW MSLAS-5 STAR: DW DOCOL DW MSTAR DW DROP DW SEMIS ; ************ ; * H DB '('+80H DW DEFIN-0EH PAREN: DW DOCOL DW LIT DW 29H DW WORD DW SEMIS ; ************ ; * QUIT * ; ************ ; DB 84H ; QUIT DB 'QUI' DB 'T'+80H DW PAREN-4 QUIT: DW DOCOL DW ZERO DW BLK DW STORE DW LBRAC QUIT /MOD * ; ************ ; DB 84H DB '/MO' DB 'D'+80H DW STAR-4 SLMOD: DW DOCOL DW TOR DW STOD DW FROMR DW MSLAS DW SEMIS ; ********* ; * / * ; ********* ; DB 81H DB '/'+80H DW SLMOD-7 SLASH: DW DOCOL DW SLMOD DW1: DW RPSTO ; BEGIN DW CR DW QUERY DW INTER DW STATE DW AT DW ZEQU DW ZBRAN ; IF DW QUIT2-$ DW PDOTQ DB 2 DB 'OK' ; ENDIF QUIT2: DW BRAN ; AGAIN DW QUIT1-$ ; ************* ; * ABORT * ; ************* ; DB 85H DB 'AB SWAP DW DROP DW SEMIS ; *********** ; * MOD * ; *********** ; DB 83H DB 'MO' DB 'D'+80H DW SLASH-4 MODD: DW DOCOL DW SLMOD DW DROP DW SEMIS ; ************* ; * */MOD * ; ************* ; DB 85H DB '*/MO' DB OR' DB 'T'+80H DW QUIT-7 ABORT: DW DOCOL DW SPSTO DW DEC DW QSTAC DW CR DW PDOTQ DB 0DH DB '4THCOMP V' DB FIGREL+30H,ADOT,FIGREV+30H DW FORTH DW DEFIN DW QUIT PAGE ; WARM START ENTRY POINT ; WRM: LXI B,WRM1 JMP NEXT WR'D'+80H DW MODD-6 SSMOD: DW DOCOL DW TOR DW MSTAR DW FROMR DW MSLAS DW SEMIS ; ********** ; * */ * ; ********** ; DB 82H DB '*' DB '/'+80H DW SSMOD-8 SSLA: DW DOCOL DW SSMOD DW SWAP DW DROP DW SEMIS ; ********M1: DW WARM ; ************ ; * WARM * ; ************ ; DB 84H DB 'WAR' DB 'M'+80H DW ABORT-8 WARM: DW DOCOL DW ABORT ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; COLD START ENTRY POINT ; ; (EVERYTHING IS RESET) ; CLD: LXI B***** ; * M/MOD * ; ************* ; DB 85H DB 'M/MO' DB 'D'+80H DW SSLA-5 MSMOD: DW DOCOL DW TOR DW ZERO DW RR DW USLAS DW FROMR DW SWAP DW TOR DW USLAS DW FROMR DW SEMIS PAGE ;**************************************,CLD1 LHLD ORIG+12H SPHL JMP NEXT CLD1: DW COLD ; ************ ; * COLD * ; ************ ; DB 84H DB 'COL' DB 'D'+80H DW WARM-7 COLD: DW DOCOL ; DW FIRST ; NOT USED IN FORTH COMP ; DW USE,STORE ; DW FIRST ; DW PREV,STORE ;********** ; * ; CP/M INTERFACE * ; * ;************************************************ ; BDOS CONSTANTS FCBK EQU 5CH BDOSK EQU 5 DB 84H ; BDOS ; ( CP/M DOS ENTRY POINT ) DB 'BDO' DB 'S'+80H DW MSMOD-8 BDOSS: DW DO DW DRZER DW LIT,0 DW LIT,EPRINT DW STORE DW LIT,ORIG+12H DW LIT,UP DW AT DW LIT,6 DW PLUS DW LIT,16 DW CMOVE DW LIT,ORIG+0CH DW AT DW LIT,FORTH+6 DW STORE DW ABORT PAGE ; ************ ; * S->D * ; ************ ; CON DW 5 DB 86H ; OPENFC ; ( OPEN FILE CONSTANT ) DB 'OPENF' DB 'C'+80H DW BDOSS-7 OPENFC: DW DOCON DW 0FH DB 86H ; MAKEFC ; ( MAKE FILE CONSTANT ) DB 'MAKEF' DB 'C'+80H DW OPENFC-9 MAKEFC: DW DOCON DW 16H DB 86H ; REA DB 84H DB 'S->' DB 'D'+80H DW COLD-7 STOD: DW $+2 POP D LXI H,0 MOV A,D ANI 80H JZ STOD1 DCX H STOD1: JMP DPUSH ; ********** ; * +- * ; ********** ; DB 82H DB '+' DB '-'+80H DW STOD-7 PM: DW DOCOL DW ZLESS DW ZDFC ; ( READ FILE CONSTANT ) DB 'READF' DB 'C'+80H DW MAKEFC-9 READFC: DW DOCON DW 14H DB 83H ; FCB ; ( FILE CONTROL BLOCK ) DB 'FC' DB 'B'+80H DW READFC-9 FCB: DW DOCON DW 5CH DB 84H ; BUFF ; ( DEFAULT BUFFER ADDRESS ) BRAN ; IF DW PM1-$ DW MINUS ; ENDIF PM1: DW SEMIS ; *********** ; * D+- * ; *********** ; DB 83H DB 'D+' DB '-'+80H DW PM-5 DPM: DW DOCOL DW ZLESS DW ZBRAN ; IF DW DPM1-$ DW DMINU ; ENDIF DPM1: DW SEMIS ; *********** DB 'BUF' DB 'F'+80H DW FCB-6 BUFF: DW DOCON DW 80H DB 85H ; FCBDN ; ( DISK NAME ) DB 'FCBD' DB 'N'+80H DW BUFF-7 FCBDN: DW DOCON DW FCBK+0 DB 85H ; FCBFN ; ( FILE NAME ) DB 'FCBF' DB 'N'+80H DW FCBDN-8 FCBFN: DW DOCO ; * ABS * ; *********** ; DB 83H DB 'AB' DB 'S'+80H DW DPM-6 ABS: DW DOCOL DW DUP DW PM DW SEMIS ; ************ ; * DABS * ; ************ ; DB 84H DB 'DAB' DB 'S'+80H DW ABS-6 DABS: DW DOCOL DW DUP DW DPM DN DW FCBK+1 DB 85H ; FCBFT ; ( FILE TYPE ) DB 'FCBF' DB 'T'+80H DW FCBFN-8 FCBFT: DW DOCON DW FCBK+9 DB 85H ; FCBRL ; ( FILES CURRENT REEL ) DB 'FCBR' DB 'L'+80H DW FCBFT-8 FCBRL: DW DOCON DW FCBK+12 DB 85H ; FCBRC ; W SEMIS ; *********** ; * MIN * ; *********** ; DB 83H DB 'MI' DB 'N'+80H DW DABS-7 MIN: DW DOCOL,TDUP DW GREAT DW ZBRAN ; IF DW MIN1-$ DW SWAP ; ENDIF MIN1: DW DROP DW SEMIS ; *********** ; * MAX * ; ***********  ( FILES RECORD COUNT ) DB 'FCBR' DB 'C'+80H DW FCBRL-8 FCBRC: DW DOCON DW FCBK+15 DB 85H ; C.REC ; ( CURRENT RECORD ) DB 'C.RE' DB 'C'+80H DW FCBRC-8 CREC: DW DOCON DW FCBK+32 DB 85H ; R.REC ; ( RANDOM RECORD # ) DB 'R.R ; DB 83H DB 'MA' DB 'X'+80H DW MIN-6 MAX: DW DOCOL,TDUP DW LESS DW ZBRAN ; IF DW MAX1-$ DW SWAP ; ENDIF MAX1: DW DROP DW SEMIS ; ********** ; * M* * ; ********** ; DB 82H DB 'M' DB '*'+80H DW MAX-6 MSTAR: DW DOCOL,E' DB 'C'+80H DW CREC-8 RREC: DW DOCON DW FCBK+33 ; IMPORTANT ENTRY FOR CP/M BDOSC: LXI D,FCBK ; FILE CONTROL BLOCK IN DE CALL BDOSK MVI D,0 MOV E,A POP B PUSH D ; ERROR CODE TO STACK JMP NEXT ; BACK TO FORTH ; *********A     ***** ; * BDOSCMD * ; ************** ; DB 87H DB 'BDOSCM' DB 'D'+80H ; BDOS COMMAND CONSTANT ENTRY DW RREC-8 BDOSCMD: DW DOCON DW BDOSC ; ************** ; * DRA * ; ************** ; DB 83H DB 'DR' DB 'A'+80H ; SET DRIV*********** ; * *RREAD * ; *************** ; DB 86H DB '*RREA' DB 'D'+80H DW SDMA-10 SRREAD: DW $+2 ; RANDOM READ OF FILE PUSH B ; SAVE INTERPRETIVE POINTER MVI C,33 JMP BDOSC ; FINISH CP/M COMMAND ; *************** ; * E 'A' DW BDOSCMD-10 DRA: DW DOCOL DW ONE DW FCB DW CSTOR DW SEMIS ; ************** ; * DRB * ; ************** ; DB 83H DB 'DR' DB 'B'+80H ; SET DRIVE 'B' DW DRA-6 DRB: DW DOCOL DW TWO DW FCB DW CSTOR DW SEMIS  RREAD * ; *************** ; DB 85H DB 'RREA' DB 'D'+80H DW SRREAD-9 RREAD: DW DOCOL ; RANDOM READ OF FILE DW ZERO DW RREC DW TWO DW PLUS DW CSTOR DW RREC DW STORE DW SRREAD DW LIT DW 25 DW QERR DW SEMIS DB 83 ; ************** ; * >FNAME * ; ************** ; DB 86H DB '>FNAM' DB 'E'+80H DW DRB-6 TFNAME: DW DOCOL ; HERE TO FILE NAME DW FCBFN DW LIT DW 11 DW BL DW FILL ; BLANK OLD NAME DW HERE DW ONEP DW FCBFN DW HERE DW CATH ; POINTER DB 'PT' DB 'R'+80H DW RREAD-8 PTRV: DW DOVAR DW 0 ; *************** ; * 8IN * ; *************** ; DB 83H DB '8I' DB 'N'+80H DW PTRV-6 EIN: DW DOCOL ; READ IN 8 BLOCKS RANDOMLY DW ZERO DW PTRV DW STORE  DW LIT DW 8 DW MIN DW CMOVE ; WRITE NEW NAME DW SEMIS ; ************** ; * >EXT * ; ************** ; DB 84H DB '>EX' DB 'T'+80H DW TFNAME-9 TOEXT: DW DOCOL ; HERE TO FILE EXTENSION DW FCBFN DW LIT DW 8 DW PLUS  DW LIT DW 8 DW ZERO DW XDO EIN2: DW DBUFF1 DW PTRV DW AT DW PLUS DW SDMA DW SRREAD DW ONE DW RREC DW PSTOR DW ZBRAN DW EIN1-$ DW LEAVE EIN1: DW LIT DW 128 DW PTRV DW PSTOR DW XLOOP,EIN2-$ DW BUFF DW SDMA DW SEMI DW LIT DW 3 DW BL DW FILL ; BLANK OLD EXTENSION DW HERE DW ONEP DW FCBFN DW LIT DW 8 DW PLUS DW HERE DW CAT DW LIT DW 3 DW MIN DW CMOVE ; WRITE NEW EXTENSION DW SEMIS ; *************** ; * KEY>FNAME * ; ***********S DB 86H ; VARIABLE 'FROM.D' DB 'FROM.' DB 'D'+80H DW EIN-6 FROMD: DW DOVAR DW 0 DB 82H ; VARIABLE 'CT' DB 'C' DB 'T'+80H DW FROMD-9 CT: DW DOVAR DW 0 ; ****************** ; * VM>RAM * ; ****************** ; DB **** ; DB 89H DB 'KEY>FNAM' DB 'E'+80H DW TOEXT-7 KEYTO: DW DOCOL ; INPUT FNAME FROM KEYBOARD DW CR DW PDOTQ DB 25,'ENTER "FILENAME.EXT" --> ' DW QUERY DW TIB,AT DW ONEP,CAT DW LIT DW 58 DW EQUAL DW ZBRAN DW KEYTO1-$ DW 86H DB 'VM>RA' DB 'M'+80H DW CT-5 VMTRAM: DW DOCOL ; FROM DISK TO BUFFER DW CT DW STORE DW FROMD,STORE DW FROMD,AT DW ZERO DW LIT,128 DW USLAS DW SWAP DW DROP DW RREC DW STORE DW EIN ; READ INTO BUFFER DW DBUFF1 DW FROMTWO DW INN DW PSTOR DW TIB,AT DW CAT DW LIT DW 66 DW SUBB DW ZBRAN DW KEYTO2-$ DW DRA DW BRAN DW KEYTO1-$ KEYTO2: DW DRB ; ELSE KEYTO1: DW LIT DW 46 DW WORD DW HERE DW ONEP DW CAT DW ZEQU DW ZBRAN DW KEYTO3-$ DWD,AT DW ZERO DW LIT,128 DW USLAS DW DROP DW PLUS DW DBUFF2 DW CT,AT DW CMOVE DW SEMIS ; *************** ; * MESSAGE * ; * NEW * ; *************** ; ERRSTR: DB 'ERROR TXT' ; ERROR.TXT IS FILE NAME DB 87H DB 'ME QUIT ; NULL ENTRY KEYTO3: DW TFNAME DW BL,WORD DW HERE,ONEP DW CAT DW ZBRAN DW KEYTO4-$ DW TOEXT KEYTO4: DW SEMIS ; *************** ; * .NOFILE * ; *************** ; DB 87H DB '.NOFIL' DB 'E'+80H DW KEYTO-12 PNOFIL: DW DOSSAG' DB 'E'+80H DW VMTRAM-9 MESS: DW DOCOL DW WARN DW AT DW ZBRAN ; IF DW MESS1-$ DW FCB ; DISK IS AVAILABLE DW PAD DW LIT,36 DW CMOVE DW FCB,ONEP DW LIT,35 DW ZERO,FILL DW LIT,ERRSTR DW FCBFN DW LIT,11 DW CMOVE DW SOPCOL ; PRINT NO FILE DW CR DW PDOTQ DB 17,'CANNOT FIND FILE ' DW FCBFN DW LIT DW 8 DW TYPE DW PDOTQ DB 1,'.' DW FCBFN DW LIT DW 8 DW PLUS DW LIT DW 3 DW TYPE DW QUIT DW SEMIS ; *************** ; * *OPEN * ; **EN DW LIT,255 DW EQUAL DW ZBRAN ; IF DW MESS4-$ DW PDOTQ DB 6,'MSG # ' DW DOT DW BRAN DW MESS5-$ MESS4: DW DUP,TWO DW SLASH DW RREAD DW ONE,ANDD DW ZBRAN ; IF DW MESS6-$ DW BUFF DW LIT,64 DW PLUS DW BRAN DW MESS7-$ M************* ; DB 85H DB '*OPE' DB 'N'+80H DW PNOFIL-10 SOPEN: DW $+2 ; OPEN A FILE PUSH B ; SAVE INTERPRETIVE POINTER MVI C,15 JMP BDOSC ; FINISH DOS COMMAND ; *************** ; * (OPEN) * ; *************** ; DB 86H DBESS6: DW BUFF MESS7: DW LIT,64 DW DTRAI DW TYPE DW SPACE MESS5: DW PAD,FCB DW LIT,36 DW CMOVE MESS1: DW BRAN ; ELSE NO DISK ." MSG" DW MESS8-$ DW PDOTQ DB 6,'MSG # ' DW DOT MESS8: DW SEMIS PAGE ;---------------------------------- '(OPEN' DB ')'+80H DW SOPEN-8 POPEN: DW DOCOL ; OPEN THE FILE IN FNAME DW FCB DW LIT DW 12 DW PLUS DW LIT DW 24 DW ZERO DW FILL DW SOPEN ; PRIMITIVE DW LIT DW 255 DW EQUAL DW ZBRAN DW POPEN1-$ DW PNOFIL ; CANNOT FIND-------- ; ; 8080 PORT FETCH AND STORE ; ( SELF MODIFYING CODE, NOT REENTRANT ) ; DB 82H ; P@ "PORT @" DB 'P' DB '@'+80H DW MESS-0AH PTAT: DW $+2 POP D ;E <- PORT# LXI H,$+5 MOV M,E IN 0 ;( PORT# MODIFIED ) MOV L,A ;L <- (PORT#) MV FILE POPEN1: DW SEMIS ; *************** ; * OPEN * ; *************** ; DB 84H DB 'OPE' DB 'N'+80H DW POPEN-9 OPEN: DW DOCOL ; ASK AND OPEN THE FILE DW KEYTO DW POPEN DW ZERO DW CREC DW CSTOR DW SEMIS ; **********I H,0 JMP HPUSH ; DB 82H ; "PORT STORE" DB 'P' DB '!'+80H DW PTAT-5 PTSTO: DW $+2 POP D ;E <- PORT# LXI H,$+7 MOV M,E POP H ;H <- CDATA MOV A,L OUT 0 ;( PORT# MODIFIED ) JMP NEXT PAGE ;----------------------------------------***** ; * *SETDMA * ; *************** ; DB 87H DB '*SETDM' DB 'A'+80H DW OPEN-7 SDMA: DW $+2 ; SET DMA POP D ; TAKE STACK ENTRY PUSH B ; SAVE INTERPRETIVE POINTER MVI C,26 CALL BDOSK ; CALL CP/M POP B JMP NEXT ; ****--------- ; ; CP/M CONSOLE & PRINTER INTERFACE ; ; CP/M BIOS CALLS USED ; ( NOTE: BELOW OFFSETS ARE 3 LOWER THAN CP/M ; DOCUMENTATION SINCE BASE ADDR = BIOS+3 ) ; KCSTAT EQU 3 ; CONSOLE STATUS KCIN EQU 6 ; CONSOLE INPUT KCOUT EQU 9 ; CONSOLE OUB     TPUT KPOUT EQU 0CH ; PRINTER OUTPUT ; ; ************* ; * EPRINT * ; ************* ; DB 86H ; ENABLE PRINTER VARIABLE DB 'EPRIN' DB 'T'+80H DW PTSTO-5 EPRT: DW DOVAR EPRINT: DW 0 ; ENABLE PRINTER VARIABLE ; ; 0 = DISABLED, 1 = E THREE DW QPAIR DW COMP DW XPLOO DW BACK DW SEMIS ; DB 0C5H ; UNTIL DB 'UNTI' DB 'L'+80H DW PLOOP-8 UNTIL: DW DOCOL DW ONE DW QPAIR DW COMP DW ZBRAN DW BACK DW SEMIS ; DB 0C3H ; END DB 'EN' DB 'D'+80H DW UNTIL-8 ENNABLED ; ; ; CP/M INTERFACE ROUTINES ; ; SERVICE REQUEST ; IOS: LHLD 1 ;(HL) <- BIOS TABLE ADDR+3 DAD D ; + SERVICE REQUEST OFFSET PCHL ; EXECUTE REQUEST ; RET FUNCTION PROVIDED BY CP/M ; ; BELOW BIOS CALLS USE 'IOS' ; CSTAT: PUSH B ; CDD: DW DOCOL DW UNTIL DW SEMIS ; DB 0C5H ; AGAIN DB 'AGAI' DB 'N'+80H DW ENDD-6 AGAIN: DW DOCOL DW ONE DW QPAIR DW COMP DW BRAN DW BACK DW SEMIS ; DB 0C6H ; REPEAT DB 'REPEA' DB 'T'+80H DW AGAIN-8 REPEA: DW DOCOL DW TOONSOLE STATUS LXI D,KCSTAT ; CHECK IF ANY CHR HAS BEEN TYPED CALL IOS POP B ; IF CHR TYPED THEN (A) <- 0FFH RET ; ELSE (A) <- 0 ; ; CHR IGNORED ; CIN: PUSH B ; CONSOLE INPUT LXI D,KCIN ; WAIT FOR CHR TO BE TYPED CALL IOS ; (A) <- CHR, (MR DW TOR DW AGAIN DW FROMR DW FROMR DW TWO DW SUBB DW ENDIFF DW SEMIS ; DB 0C2H ; IF DB 'I' DB 'F'+80H DW REPEA-9 IFF: DW DOCOL DW COMP DW ZBRAN DW HERE DW ZERO DW COMMA DW TWO DW SEMIS ; DB 0C4H ; ELSE DB 'ELS'SB) <- 0 POP B RET ; COUT: PUSH H ; CONSOLE OUTPUT LXI D,KCOUT ; WAIT UNTIL READY CALL IOS ; THEN OUTPUT (C) POP H RET ; POUT: LXI D,KPOUT ; PRINTER OUTPUT CALL IOS ; WAIT UNTIL READY RET ; THEN OUTPUT (C) ; CPOUT: PUSH B CALL COUT DB 'E'+80H DW IFF-5 ELSEE: DW DOCOL DW TWO DW QPAIR DW COMP DW BRAN DW HERE DW ZERO DW COMMA DW SWAP DW TWO DW ENDIFF DW TWO DW SEMIS ; DB 0C5H ; WHILE DB 'WHIL' DB 'E'+80H DW ELSEE-7 WHILE: DW DOCOL DW IFF DW TW ; OUTPUT (C) TO CONSOLE POP B XCHG LXI H,EPRINT MOV A,M ; IF (EPRINT) <> 0 ORA A JZ CPOU1 CALL POUT CPOU1: RET ; ; FORTH TO CP/M SERIAL IO INTERFACE ; PQTER: CALL CSTAT ; IF CHR TYPED LXI H,0 ORA A JZ PQTE1 INR L ; THEN (S1) <- OP DW SEMIS ; DB 86H ; SPACES DB 'SPACE' DB 'S'+80H DW WHILE-8 SPACS: DW DOCOL DW ZERO DW MAX DW DDUP DW ZBRAN ; IF DW SPAX1-$ DW ZERO DW XDO ; DO SPAX2: DW SPACE DW XLOOP ; LOOP ENDIF DW SPAX2-$ SPAX1: DW SEMIS ; DB 82H TRUE PQTE1: JMP HPUSH ; ELSE (S1) <- FALSE ; PKEY: CALL CIN ; READ CHR FROM CONSOLE CPI DLE ; IF CHR = (^P) MOV E,A JNZ PKEY1 LXI H,EPRINT ; THEN TOGGLE (EPRINT)LSB MVI E,ABL ; CHR <- BLANK MOV A,M XRI 1 MOV M,A PKEY1: MOV L,E MVI H,; <# DB '<' DB '#'+80H DW SPACS-9 BDIGS: DW DOCOL DW PAD DW HLD DW STORE DW SEMIS ; DB 82H ; #> DB '#' DB '>'+80H DW BDIGS-5 EDIGS: DW DOCOL DW DROP DW DROP DW HLD DW AT DW PAD DW OVER DW SUBB DW SEMIS ; DB 84H ;0 JMP HPUSH ; (S1)LB <- CHR ; PEMIT: DW $+2 ; (EMIT) ORPHAN POP H ; (L) <- (S1)LB = CHR PUSH B ; SAVE (IP) MOV C,L CALL CPOUT ; OUTPUT CHR TO CONSOLE ; ; & MAYBE PRINTER POP B ; RESTORE (IP) JMP NEXT ; PCR: DW $+2 ; (CR) ORPHAN PUSH  SIGN DB 'SIG' DB 'N'+80H DW EDIGS-5 SIGN: DW DOCOL DW ROT DW ZLESS DW ZBRAN ; IF DW SIGN1-$ DW LIT DW 2DH DW HOLD ; ENDIF SIGN1: DW SEMIS ; DB 81H ; # DB '#'+80H DW SIGN-7 DIG: DW DOCOL DW BASE DW AT DW MSMOD DW ROT B ; SAVE (IP) MVI C,ACR ; OUTPUT (CR) TO CONSOLE CALL CPOUT ; & MAYBE TO PRINTER MVI C,LF ; OUTPUT (LF) TO CONSOLE CALL CPOUT ; & MAYBE TO PRINTER POP B ; RESTORE (IP) JMP NEXT ; ;---------------------------------------------------- PAGE ; DW LIT DW 9 DW OVER DW LESS DW ZBRAN ; IF DW DIG1-$ DW LIT DW 7 DW PLUS ; ENDIF DIG1: DW LIT DW 30H DW PLUS DW HOLD DW SEMIS ; DB 82H ; #S DB '#' DB 'S'+80H DW DIG-4 DIGS: DW DOCOL DIGS1: DW DIG ; BEGIN DW OVER DW O DB 0C1H ; ' ( TICK ) DB 0A7H DW EPRT-9 TICK: DW DOCOL DW DFIND DW ZEQU DW ZERO DW QERR DW DROP DW LITER DW SEMIS ; DB 86H ; FORGET DB 'FORGE' DB 'T'+80H DW TICK-4 FORG: DW DOCOL DW CURR DW AT DW CONT DW AT DW SUBB VER DW ORR DW ZEQU DW ZBRAN ; UNTIL DW DIGS1-$ DW SEMIS ; DB 83H ; D.R DB 'D.' DB 'R'+80H DW DIGS-5 DDOTR: DW DOCOL DW TOR DW SWAP DW OVER DW DABS DW BDIGS DW DIGS DW SIGN DW EDIGS DW FROMR DW OVER DW SUBB DW SPA DW LIT DW 18H DW QERR DW TICK DW DUP DW FENCE DW AT DW LESS DW LIT DW 15H DW QERR DW DUP DW NFA DW DP DW STORE DW LFA DW AT DW CONT DW AT DW STORE DW SEMIS ; DB 84H ; BACK DB 'BAC' DB 'K'+80H DW FORG-9 BACS DW TYPE DW SEMIS ; DB 82H ; .R DB '.' DB 'R'+80H DW DDOTR-6 DOTR: DW DOCOL DW TOR DW STOD DW FROMR DW DDOTR DW SEMIS ; DB 82H ; D. DB 'D' DB '.'+80H DW DOTR-5 DDOT: DW DOCOL DW ZERO DW DDOTR DW SPACE DW SEMIS ;CK: DW DOCOL DW HERE DW SUBB DW COMMA DW SEMIS ; DB 0C5H ; BEGIN DB 'BEGI' DB 'N'+80H DW BACK-7 BEGIN: DW DOCOL DW QCOMP DW HERE DW ONE DW SEMIS ; DB 0C5H ; ENDIF DB 'ENDI' DB 'F'+80H DW BEGIN-8 ENDIFF: DW DOCOL DW QCO DB 81H ; . DB '.'+80H DW DDOT-5 DOT: DW DOCOL DW STOD DW DDOT DW SEMIS ; DB 81H ; ? DB '?'+80H DW DOT-4 QUES: DW DOCOL DW AT DW DOT DW SEMIS ; DB 82H ; U. DB 'U' DB '.'+80H DW QUES-4 UDOT: DW DOCOL DW ZERO DW DDOT MP DW TWO DW QPAIR DW HERE DW OVER DW SUBB DW SWAP DW STORE DW SEMIS ; DB 0C4H ; THEN DB 'THE' DB 'N'+80H DW ENDIFF-8 THEN: DW DOCOL DW ENDIFF DW SEMIS ; DB 0C2H ; DO DB 'D' DB 'O'+80H DW THEN-7 DO: DW DOCOL DW COM DW SEMIS ; DB 85H ; VLIST DB 'VLIS' DB 'T'+80H DW UDOT-5 VLIST: DW DOCOL DW LIT DW 80H DW OUTT DW STORE DW CONT DW AT DW AT VLIS1: DW OUTT ; BEGIN DW AT DW CSLL DW GREAT DW ZBRAN ; IF DW VLIS2-$ DW CR DW ZERO DW OP DW XDO DW HERE DW THREE DW SEMIS ; DB 0C4H ; LOOP DB 'LOO' DB 'P'+80H DW DO-5 LOOP: DW DOCOL DW THREE DW QPAIR DW COMP DW XLOOP DW BACK DW SEMIS ; DB 0C5H ; +LOOP DB '+LOO' DB 'P'+80H DW LOOP-7 PLOOP: DW DOCOL DWUTT DW STORE ; ENDIF VLIS2: DW DUP DW IDDOT DW SPACE DW SPACE DW PFA DW LFA DW AT DW DUP DW ZEQU DW QTERM DW ORR DW ZBRAN ; UNTIL DW VLIS1-$ DW DROP DW SEMIS ; ;------ EXIT CP/M ----------------------- ; DB 83H ; BYE C     DB 'BY' DB 'E'+80H DW VLIST-8 BYE: DW $+2 JMP 0 ;----------------------------------------------- PAGE ; ******************************* ; *** "NEXT" CONSTANT *** ; ******************************* ; ; USED BY THE ASSEMBLER EXTENSION ; DB 84H ; NEXT DB 'NEX' DB 'T'+80H DW BYE-6 NNEXT: DW DOCON DW NEXT ; ********************** ; *** "TASK" *** ; ********************** ; ; THE LAST WORD IN THE DICTIONARY ; DB 84H ; TASK DB 'TAS' DB 'K'+80H DW NNEXT-7 TASK: DW DOCOL DW SEMIS ; INITDP: ; DS EM-$ ;CONSUME MEMORY TO LIMIT ; PAGE ; ; MEMORY MAP ; ( THE FOLLOWING EQUATES ARE NOT REFERENCED ELSEWHERE ) ; ; LOCATION CONTENTS ; -------- -------- ;MCOLD EQU ORIG ;JMP TO COLD START ;MWARM EQU ORIG+4 ;JMP TO WARM START ;MA2 EQU ORIG+8 ;COLD START PARAMETERS ;MUP EQU UP ;USER VARIABLES' BASE 'REG' ;MRP EQU RPP ;RETURN STACK 'REGISTER' ; ;MDPUSH EQU DPUSH ;ADDRESS INTERPRETER ;MHPUSH EQU HPUSH ;MNEXT EQU NEXT ; ;MDP0 EQU DP0 ;START FORTH DICTIONARY ;MDIO EQU DRIVE ;CP/M DISK INTERFACE ;MCIO EQU EPRINT ;CONSOLE & PRINTER INTERFACE ;MIDP EQU INITDP ;END INITIAL FORTH DICTIONARY ; = COLD (DP) VALUE ; = COLD (FENCE) VALUE ; | NEW ; | DEFINITIONS ; V ; ; ^ ; | DATA ; | STACK ;MIS0 EQU INITS0 ; = COLD (SP) VALUE = (S0) ; = (TIB) ; | TERMINAL INPUT ; | BUFFER ; V ; ; ^ ; | RETURN ; | STACK ;MIR0 EQU INITR0 ;START USER VARIABLES ; = COLD (RP) VALUE = (R0) ; = (UP) ; ;END USER VARIABLES ;MFIRST EQU BUF1 ;START DISK BUFFERS ; = FIRST ;MEND EQU EM-1 ;END DISK BUFFERS ;MLIMIT EQU EM ;LAST MEMORY LOC USED + 1 ; = LIMIT ; ; END D     E     F     G     H     I     J     K     L