From dd5b8b369db24d1d26d778c83bb7b5915fdf6e8d Mon Sep 17 00:00:00 2001 From: Richard Russell Date: Mon, 27 May 2024 15:06:09 +0100 Subject: [PATCH] 2024/05/27 : Initial commit --- .gitignore | 49 + README.md | 17 + WHATSNEW.TXT | 68 + bin/cpm/BBCBASIC.COM | Bin 0 -> 18944 bytes bin/cpm/MAKE.SUB | 14 + licence.txt | 19 + src/ASMB.Z80 | 1009 +++++++++++++ src/CMOS.Z80 | 1493 +++++++++++++++++++ src/DATA.Z80 | 68 + src/DIST.Z80 | 227 +++ src/EVAL.Z80 | 2586 +++++++++++++++++++++++++++++++++ src/EXEC.Z80 | 3273 ++++++++++++++++++++++++++++++++++++++++++ src/HOOK.Z80 | 63 + src/MAIN.Z80 | 2236 +++++++++++++++++++++++++++++ src/MATH.Z80 | 2266 +++++++++++++++++++++++++++++ tests/ALLTESTS.BBC | Bin 0 -> 384 bytes tests/ARRAYTST.BBC | Bin 0 -> 12752 bytes tests/BYREFTST.BBC | Bin 0 -> 2688 bytes tests/ERRORTST.BBC | Bin 0 -> 4224 bytes tests/EXITTEST.BBC | Bin 0 -> 1261 bytes tests/FILETEST.BBC | Bin 0 -> 1920 bytes tests/FORTEST.BBC | Bin 0 -> 3832 bytes tests/INT32TST.BBC | Bin 0 -> 2944 bytes tests/SLICETST.BBC | Bin 0 -> 9984 bytes 24 files changed, 13388 insertions(+) create mode 100644 .gitignore create mode 100644 README.md create mode 100644 WHATSNEW.TXT create mode 100644 bin/cpm/BBCBASIC.COM create mode 100644 bin/cpm/MAKE.SUB create mode 100644 licence.txt create mode 100644 src/ASMB.Z80 create mode 100644 src/CMOS.Z80 create mode 100644 src/DATA.Z80 create mode 100644 src/DIST.Z80 create mode 100644 src/EVAL.Z80 create mode 100644 src/EXEC.Z80 create mode 100644 src/HOOK.Z80 create mode 100644 src/MAIN.Z80 create mode 100644 src/MATH.Z80 create mode 100644 tests/ALLTESTS.BBC create mode 100644 tests/ARRAYTST.BBC create mode 100644 tests/BYREFTST.BBC create mode 100644 tests/ERRORTST.BBC create mode 100644 tests/EXITTEST.BBC create mode 100644 tests/FILETEST.BBC create mode 100644 tests/FORTEST.BBC create mode 100644 tests/INT32TST.BBC create mode 100644 tests/SLICETST.BBC diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..5c8daed --- /dev/null +++ b/.gitignore @@ -0,0 +1,49 @@ +# Prerequisites +*.d +*.bat + +# Object files +*.o +*.ko +*.obj +build/ + +# Linker output +*.ilk +*.map +*.exp + +# Precompiled Headers +*.gch +*.pch + +# Libraries +*.lib +*.a +*.la +*.lo + +# Shared objects (inc. Windows DLLs) +*.dll +*.so +*.so.* +*.dylib + +# Executables +*.exe +*.out +*.app +*.i*86 +*.x86_64 +*.hex + +# Debug files +*.dSYM/ +*.su +*.idb +*.pdb + +# Editor files +*~ +#* +.#* diff --git a/README.md b/README.md new file mode 100644 index 0000000..5d821cd --- /dev/null +++ b/README.md @@ -0,0 +1,17 @@ +# BBCZ80 +BBC BASIC (Z80) v5 is an implementation of the BBC BASIC programming language for the Z80 CPU. +It is largely compatible with Acorn's ARM BASIC V but with a few language extensions based on +features of 'BBC BASIC for Windows' and 'BBC BASIC for SDL 2.0'. These extensions include the +EXIT statement, the address-of operator (^) and byte (8-bit) variables and arrays (& suffix). + +More details of the features added in version 5.00 can be found in the file WHATSNEW.TXT. + +![Architecture](https://www.bbcbasic.co.uk/bbcbasic/z80arch.png) + +The files in green constitute the generic BBC BASIC interpreter which is shared by all the +editions, it (just!) fits in 16 Kbytes so could be held in a ROM of this size. The files in +the blue box are used to build the CP/M edition. The files in the red box are used to build +the Acorn Z80 Second Processor edition (in principle: the source files are on an 8" floppy!) + +Note that the name 'BBC BASIC' is used by permission of the British Broadcasting Corporation +and is not transferrable to a derived or forked work. diff --git a/WHATSNEW.TXT b/WHATSNEW.TXT new file mode 100644 index 0000000..41621cc --- /dev/null +++ b/WHATSNEW.TXT @@ -0,0 +1,68 @@ +New features in BBC BASIC (Z80) version 5.00, May 2024: + +1. BASIC V statements + +1.1 WHILE...ENDWHILE +1.2 Multi-line IF...THEN...ELSE...ENDIF +1.3 CASE...WHEN...OTHERWISE...ENDCASE +1.4 LOCAL DATA / RESTORE DATA +1.5 ON ERROR LOCAL / RESTORE ERROR +1.6 DIM var LOCAL size +1.7 ERROR err, message$ +1.8 RESTORE +n +1.9 SWAP var1,var2 +1.10 BPUT #file,string$[;] +1.11 QUIT + +2. BASIC V functions + +2.1 DIM(array()[,sub]) +2.2 END (pointer to free space) +2.3 REPORT$ +2.4 Binary constants +2.5 LEFT$ & RIGHT$ with last parameter omitted +2.6 MOD(array) +2.7 SUM(array) +2.8 SUMLEN(array) +2.9 GET$#file + +3. BASIC V whole array operations + +3.1 Pass a whole array to a FN/PROC +3.2 Pass a whole array to CALL +3.3 Whole array assignment +3.4 Whole array arithmetic * +3.5 Array dot-product operator +3.6 Array initialisation lists +3.7 Array compound assignment (+= etc.) +3.8 Make a whole array LOCAL +3.9 DIM a LOCAL array (on the stack) + + +* String array expressions A$() = B$() + C$() are not currently supported. ++ LOCAL string arrays should be initialised to their maximum needed length + to eliminate the risk of a memory leak each time the PROC/FN is called: + LOCAL a$() : DIM a$(size%) : a$() = STRING$(max%, "a") : a$() = "" + +4. Miscellaneous BASIC V features + +4.1 Bit-shifts <<, >>, >>> +4.2 Floating-point indirection (|) +4.3 RETURNed parameters from FN/PROC +4.4 Compound assignment (+=, -=, *=, /= etc.) +4.5 Assigning to a sub-string: LEFT$()=, MID$()= , RIGHT$()= +4.6 Hooks for CIRCLE,ELLIPSE,FILL,LINE,MOUSE,ORIGIN,RECTANGLE,TINT,SYS,WAIT +4.7 Hooks for WIDTH function, TINT function, MODE function + +5. Extensions to Acorn's BASIC V, compatible with BB4W, BBCSDL and BBCTTY + +5.1 EXIT REPEAT / WHILE / FOR [var] +5.2 Address-of operator ^ +5.3 Byte variables and arrays (& suffix) +5.4 'BY len' and 'TO term' qualifiers to GET$#file +5.5 ELSE IF THEN; (trailing semicolon) +5.6 == synonymous with = in comparisons +5.7 DIM a global array inside a FN/PROC (use RETURN) + +Note: The token for PUT has changed from &CE in version 3 to &0E in version 5. +If this token is present in existing programs it will list as ENDWHILE rather +than PUT, and the programs will need to be modified to restore functionality. diff --git a/bin/cpm/BBCBASIC.COM b/bin/cpm/BBCBASIC.COM new file mode 100644 index 0000000000000000000000000000000000000000..7ca5625c02b49dcdadeb44e9a371eb8796611894 GIT binary patch literal 18944 zcmdUXi(gac{r?G<5N;s>#luBBA%I6NnraI{;Xoh(Q9@WiZP&F{TWf8tST7Y6DQ(wv z-?i(y`+dD^>sGh#&~{z47fTGWiQ#m_8OQ0@SW^sBW1OJ|m72rv{hZis-{0%^5BwC) zd7kGym(S<(d~VO@c^(`kGRH?UhfC&g%N&o$9BX8b-^m=^GJh}@UGJ~gOHg%iq7?q$*Mf#(To?Xla=Bs*L2}w0~E-^DpOFnY)Ps_rqugX$G;nh>J z@T!pA?eqmvXfy|G;ilrNvZmDmyr*P#xAF%1@r7*Rjj}IhIVM$~5N`71c(Nxvb3Jn= z!jIN7mqT8+leG5c1(oumS=0~MYM3;sC~OVsFWTL1x0<3f6h+2auS_6SymmMB|NhsR zk|kHtin(bS*=k35g5xI%j^){ox-`dRmg7{GYQcChNhrQz=7X)_uFuTHXUu$A`msN$_{prMre>ze(ACz= zuprJNX6>dOJGb;~WA56xY1f9OnQ3hEBBr@#d*6;Nn;+T5SQmFMw(j1!bJNzX%u?Ob zJ2TU$>6-Aq&&>SMl^W4JFqt*2+Y{bce92sV*<5_hTzPUryIhtNGcLLrcFf$B@)G9iMKHL-2^4GI2_P;Z_ zONoSSYtchwWbN6WX2H9a{7l%FN6RALJ9#9Y0MNG;|n$U})<4p`p3! zM+W0sL;H^nUClo+banjH(B1K~rdCro<7?_%)6HZx-NSs*Y-zWwu}UxN>1IQFyQ|sI zW%_&bN<&-62hA(3C9>u=YjeA49KQxDBQ&>Lx=hR`&F!ts|1`IEF+Xp%bp4{)vZkY( zIb$?*8-8gtwfc>wmZyzvYtI_n%%2*qhII+1_V%{UE|bU9VIRW&+uBXcIi#4+OdV@Y?Uqi{3#Rri)2k*R@hg+Hoq5h=wOXuBlcj}GneJ}uW}Y!w ztgoPudChcp=j*1syP1g=i}lwn1~g+5TiV*&f78+tY_)V-jsowJ-{Nt;)zY=5X|ffF ze}840*<@xev~_?S|7dIZu&raY>7J4|q*q2;M^`uK@%y%p?%$ELmHkG0TZid;?H1DL zQo9Az8g4hWbeFJiwwpRGwwt>D&~9lx(B5G;w;4;=klA81J&Q+@*|Mg~blGfKYYKM& z#y@sgx|1!|w$`?eQA_tqlXYENm+6Y7<9SO<3v&XvecfVx3CMS}b^M9EENi;|o4nU_ z&RV*f+uI_YR>1Ufr=iuve5bS9$_#b3F;_d=E!_t@E%?GJfzA}6>!D6d7bE}58c^zn z)zrPl+QCGvrcRTgdm1l`wVV0eYBCtFSxx4f)-@f>TULYdy4BRxZLyk;0l<~O?QJV2 zB*kiK?lyF^wwu1$)otqhb60D}J6&xZf9d*)^}o70n;oD|$p{{89jztosV=aCaR$9~ zGRM2tm=#^?44tW6_jK9N#fw0=<8Zg-Tiu2x_Exvm&}{l{H>QC}>jvmYx~*$WObp!A z*8c9AF6%$n8rQss*?)g6!9-lwX6#;>zRm!A-0RTKM-tEc6*TaYKK>@n=SgXT#t3=T z<}EvSZrQe($?oW3cJ6-g5hkZ;!$Zs*X2*tYn>WpUa>I@-8#Zp;lxx|&i|KiI9xBny z&g~l>+>}RD?3QiNxB1N0o}TRm%r+Fv&JG&ZbX%S_nlRUr-|my- zyeTSY_s&g#nc1*o$A&&CXXoyXJ0IM!W&19wt8d$`4ZX~!9XonhwQnOdJ&cL$fjNb*2XQ{Htgu5vVXG#&^@?e>sBgf z!;a0nA4lDtRNh2B)x2Tb!d;An7BfNROfYkS+F^>Ccb>Y!?3BQ!uFRpbw{F?CiOOZp zPlwv4_W-w<`y1 zCw`KkyyDTDrmI?g6)7%icq#eZ-V zGgngEp;$1$WjbY)EPSYMi9NKw_YfmX7yPgkMU=qJfeBO$*jVMh_*gz^Fz?BqBy_ZD zwOVN9OkZ&5a4hH@ag+zVvEZmFJr+>Z^SLVn_vcc1UOW8(Uy;uLN-30|F^BIxYer`k z+74|?=n3t1tq>%pMzE7~sG?%1wIekYEP*iy>Hp5xrRCC8sCrggJxdyr4m$b>+CoT6 zpwaq5f>$ySfI?1j-wq#Q&N_p^SU?E!cT@%hqq+R7nN);B&=evGeI&%@!=koq*s^ug zL(GO<3?&4G0N}DTt%2*mR7f+dOYr)#;3)!_;{2_ z7GJycdK!}AVphdpQ0kLn0opqtGR*Z@MP#Vg?F$CwR7Yws1o-2IIeakSbrXy<)NCy& zA{f2XbgC?!qhP^NucCSuKXegjgh|Ql$jD?Y*{I`mDv0LBhiWS5jG}JwS#$9@ zvu3MVzP*~#s=kQW1MVQ)g24=XU_j73ppYr3@S)L9(?t&+9OL&;EhCrH_dSn9$H)bZ zFaRc%rBIrC6sYD;7hQM=16nbYEnO$7m;}!kVlg8t|<9#N^`&1^;AMF)i z6i5?#5s2#q*VqN85A5Kz3lI#qr+pCKzlfP`Eq&$>44oG z0v(2q){TMbF)eVT!q&i8Dm^8q!uP@}J7WgJZ9Q%!uBCITvK|c{~Z?? zldv$+CJd#d=maGrPgbiI4u!3Cx-atT*(6WEbCE#MD<-q@Mcwx;T9l{0kf=Ia;|2$4 zgZ{wY>BbM;e3_E)0L$!;4amer>;$KDR7h;0VV@Km@Y~Ps7E9RO{LeCn<26^uYaa0t zz$e8&v!jq}7d$m8ihg}W1$ieR<=Tmmk5ABg^N0v?S-Rf^BK1rm-&qw2@>9iuymh3z z2DVJputfx%58YATSVe!pCDExvw46((6S%?f#wa~koO8h&WG+g_fYuWbLJft zJ41W4d(a%hz;S$)Cy|$@MN-hb-^~?;!hUbd{LvE;Z z@B^SYts589#$sB`vOa5(J|j<`x=1fy4<)P%aC0!B{4QnxJ50jjG=853lcY(bMs_JD z?7fGEp=!IfY~9*Np-K>6*;Mf#Kv0Y91e|s|2uq12K*1%lz{VwFsO1e~VxvnmjEnao zwSHXO*Wk_u8TN^{xEyE#(j?PGuuAg0>G`S1umQ1>^^2|g1mudDWRJSRljqsMsywej zYdmb1AeC4NUQ7k{8jINm5;W0S-)kn9L1I2E&- z%ugxN=S8s$g@WewET;@2bjXfeK=TH2$+vTM2bC2(fBn{rFGQbP?g@mdzpdRnIh>W% zx^Hs$U{=}X=abpZylt1r zn(#szu_u1bv^l(%H zc47_)n|Je**uAL+$eXQv}JJl z8cwC*)EZ8y;p9Y2LFC&ceM+aF06D||TDH?e{28s{`F(m>pCTyOLxNpXojVk6V$+=b zlMEB#Qs@t20n%IuIfZ~?y=8$r78Ern9?XI6{=}R!a$D6OdoTwYb6`@`{sl?<-tu$i zpnoD5Rm-TRnAYj@V*y|4>1Xx|T7ST=_3x(e*hSf)%k^7A_9Vgvm8{RNC8`{nT;Cno z?w<%u4*LH>1xxburtl7(ArK6&J_j?_gcUvFFs&@nRB#%?O*efo|GFH~?JimGAvV<) z0tDfMAun{T5*n_6p61dtTsr81o|0;by1Sg^_+fS|z*lA4*w1FnIi5Yt|FjZXUV=B9 z7}M58dj$;8&es%4;QIrDmUJ6&$a6$3^AOKy(T9&vaK@eEbqf0h-qbAgljnZ?_T$$M zudA6JU+o2x5XWUe>m;T0HCTOo_)wle7lU!=`3T?)9c5Lp{x&x4M{J7ji?ETupjl3t z5f~vtruPg&9tK!mT!G(8_GA7v4LcdDa7yDh%<=j>tD>W?RYpecue3Y+zJKb1#?DV` zXosh96uxK!w6CPu#Y@cmm=^wD5YAyxLnQ?@NNajDNK>__gD6f6f+{|LtXCb=!ZSov z=aLzWCqBo%i&?}}#k570VvtQ2&$B5-Q}1yLnf7%M348CK-(i*>VwYsHY69{?09?%G zzsF2vGXLBM)w;+B>+0Q$rd9m&8oHK0TMR9CO6n0>U}>J1$xLx9CW*V^sLn-YbaSjG zTY%AkES@;0;ug^X6eIk{7x4*my&BD2xHYi=tK-V(kK)BqmEEb)qr8bt=Mo7Y|C6hr z4*+z&ywdJvl6_7e1UstYis>If)R^m0!hVOj66U#>7E>K7@dqNUaJew~LQo^41oHix zOzOYB$`#<{1bK!t2()8Cv;jC6S94GrHpBVlxD5R$PzVH_!4W>g3#Y}(wEFxS1?8{h zkCpic()|Ir9#JlxpS(-o5FxCl$@uc)EGaB6VbV0&RP9ah8vQG~7vdQ7IRU*?NJb1d zp?~(boCb7@^2>9{FW`YIfe>7#ovr1H^yi&Wx167EEY@p4Nr@To5$h~{Dv{x!7lE-5 zmkFguk3%K~Gr9T95PTI)g2WWQ*o0SPkKH+s$Onrli3RO~Vo1R!Y7{m$HyAedgpFmh zixw@KfPB~bZ$|kKa}^L~!5Iq#`8f*$6E@k0x#6bN3FbauP?JK{4iJA4?nDTU^5P3H zICxGFv(>*X$^URNh{dLc)Sy*fNOc+dkC@;|bt2{2&M1nKJ-uwgJvn*ADGY&q$&!qH zHvl{ac8FJ)3_uJX1K9A4KrQguO|bn{bC7F{YVaZ)PfvoUgW?%B2#%@FB^;yGESKH| z@h;gMjV?#xB+ZAUoXa={R|L32NhfLua!|V<2Xx0An}T;&Dx%kFiX!*i`eqTCuh0C| zl+0f(qv(ho9TUx(ep|CpXAgcic)Xal{F@enCgU=AW||4M5O| z7%*V>JWapiF)(RdgJe$ez?ftT5#l8i)=J{Mhg}2k+_b8jZc%$8I1h6$ATA$u(PS7^ zUJ!!@Y%^3|Fg8I(kc1B-#3twzKCw7R#(}#)sOf^|pdI7N>4)O7%$5_md=YC{c+p6$ zV6PMQ{5A?4vvW`atXD8;bP>@rQm&Z2CSE(ys}?h%OT-u0G4VwvNSbCcW3m@0^@}_t zV{P$?TPp4j%#SQK8%ve(q@0vSRrG~;k%v;B@WhL_CA4G$0R7{y75w*8 z{lw)FKg0?)pE!`PGO1+61_Qx- z8h0#7Z}8CKfhg#+`RqStmK0!Be1!cVbv|>09_Mql{0}tyqNoAE5xkla+8eS1|H^lGOrJ z<}>o@oRP(P>c2z*^R z^#Fopicnq%w1U$v>Bk8s1Hcns3#OWz$d#?%_oY2Az3oou!S=)$EO+{00wfzRIQ;?U zG*<~`wQH0x)8Yj4kv|x~4jA?dWfNg`?i~6rb}`Bvl0{>*!Y+Qq{0`CtS%P`G&8yO4 z0TW{nZy_ao#`uUWV;v|H)2;+Z^a&v$WSHomfcG%5e_}EV zRGGXBU%_~L5uC}6W@L_BU?XA@oA#jqzgTelpGYDJILLS<_;)3`_lp(%AUh}uGj^#G zi2(m;nY|Z|ssfZS)`kz>j0HfV1v*QRPb}Lf^z;kw=}Lr6goP}r#2bh6!Dc_O1=F=} z{rq1uU(|SV_Q7t|@SR0+YIP`(nc)f_91C}0Jpk94gkr~sK&#dMpm(VC2xxQ=@lAIe zF8`hc*Z|3$!pf;C8=l1OB>%2t{~mcP5JBk9pGsG8vxo@g_}~AV6cr1j#`XRDX25vA|wNJpym4mhiE^HtGu^_$c&Z0wM0QSt@+6 zl|Q`z0t#&}Wd(#K1KtRoX7}_4?5VXQtoA0I>?O_ZxBZ`d8X}MF@qoK#`aMtE{dKoRDisu35chO!@CPKdwK;~!h zd8faJE#jN>ix{>RrBhMgJ-z%li@cGW^d+w}znEx+qD~>DeLxD!@2YHoZWp|uT()h- zr~$=VK{{aqMwZsa=L^$R7WLr^2#4WUdqK_!Mlpq(YHzkWu}lOdLZLBwyd8RCDjdU4?}tl5y;Nz|)7 zuDsP?ko}r3%tu|(Gr{!8k7$GiaZ&&kymq3>gAbYGVDaa9>Gz9)dShYpDLs!ZwD)=6RXQ&6)4BJ*3%dm5>Zrs9ek_hJ&=v$1!^1`-dm^N+Ck@3O^CITh}!7Wfk+8ED7a9?y9Lrf&H|M#O`hr1EI5GQN`*Gvx|CUqk^cK5Mta+N*)e!oHPH~ z8&D=eafcYc4NPNW{u*)LQCZ2hvEst7u-6veT=+{?V5bd%g>_p{`%|=eW8s@@`J(@3?d&`35jK&1iTy_5 zRrZeyua}GE>nmQV=&9f<{;TqO#i51oF6w8$&OXU*VZX)puzW--KEo!8Umxc0t3rl< zyo$cUCzObTQb9rqDVXB-mhda8hFc}hM~X>_X%Dl7gRQ-a8FPu^bdtE7NjRP`nZ<9Y zB6T0Ha>G1)1`11+50jOeHmUb?Hhor6KbZoZ5k)n{R6}Wm#3bPPNg}|%Smh0s!Fq*; zEDFqvn|GCnRq#J5h7~hEC{Yj)T@pkWi4b0@M2>W_+Uoe9>% z_L=@GgPW15%Em6AL&L^32E^gpdWHDWC*P}b$QFvrb)}+Cw+})0XF$W_a8;kde%NDT z8T+(Y%Kj1|ksV^%iPsj2&z>kM7w=~e!2v`}ZwWNnfNkc}GS50C#pXh*Ci**IvLzFN zSAzfHMCb-eD5Fp&xId}MUM`wFJzPFhjX4pNx|@DYqj|_ed&tt?AK*$z{2-rL_aUM- z;__C^re_yIRwI(Up-hAZVK2ujxIwqHPlEt8JB_%Vw6Km!yDgDWJ#&@F9f9+C&z>6g znaS_8ez{fSmL!s8J_Qsnm4VuB&pP>+7_TBCCC&qQMVXE$Q4T&Jf>N-cnQi{N%M=_rMo z4i(O4^8y3f_w+gQXMVgeFOMKxfnj^fDEbDMMfeS?fqi_cEJW|dlip6;^Zw=&FR>2r z5z<(_)A#V}D`+W3%Q9(1Um4BeN9bl=ET+Q59~o;UG;ZTgX#oo;*1dmtN0(tgJ!xxkt^Li^!7X zj#5(7(_h0}MldjHfESJWBl<;x@+pM$6p}{BWUhJMkGO<=^=}DpzXh(u>PdnW>nulc zDTwy_GEeV`hEjfa8RTqeb5AS$jZ|flKeb@*+sx-gF@U|^WPMUaW}!1)5y~avi}Hud zq;MZFkK|J8{dwMk*1d1{GC_B|RtN}_jmZv*sMTk=98`=;KlaMW7!}xcJ2#C*zh zY$oVbA}Ws6B3u}JNh&1@K42%3%gX8jGVdt&vWel1wc#CcO9H6^A>de8QtjW>v0mhD3hpF-GE_c{6p^PSu#t)esCTJ)v|Kly0V78mqf{s z&%$QiVJ0J{g<_IK$qRpOwRo6Sd<9{2@;R6CU^{nXvt3{4S;^)cVduj8R3HkXfKEt7 z%q)3Nn>;8*7w_p39$WvPwKL+iFV`z&K=SR1F?f5c_kX`fPHns!%OUiO zNVSnP#gT?mRF2r#qxD2TqGI#L#gubEn_bA|oTx}sMeUi)RWyMW{PR14n*^$3+IjOf zPY%cagj7%eym_~io8!6y@U1T8@2@1oTwt-L0`^XM(vZaX^HewNnKxLuje%!)@%YON zKW@uc_I>!E5!8=|LE zDgJL@ow(|-xRWxH*);g1`A3IywDjk;OjnKDmO*@8*ix)0x>tv-ao;>7ryju(O_XA# z0lR0c#Yk{xv1GjIzerR+c8!-djGxv?+sU`LkPYLfYeZFpTja*X`Z2LC?rg#<#@0XK zDA?*nF0KH&o45dqnTApYRt!Sad6A?Ay8!8k#N|YA3P4MLYDn^kf|@ZcEf1dlw&rVE zC)tIRwjk{jZfwu_Cu}qCSCNI=1V6VZ;9VuB+&-*10?4mN9xk-o^OleQRT)Iw-s^)5 zO%*q-#&Ug#_+Z$)tVnZ`)pQa9QAxHc-tDkgQff19v5Lt+?16Zo_)=6A#4ZY1bTex`dswU8>#@BH zWpo?Krq$jF)bay`Ax4xqEW67hp}3c|ttv#K2Qh5dAnqZfSb6N>+1NHQ>LZ(Q zICc{8x6JxGM2V2GVCOwiNu__ObKz-W_XGMpo``;FHg5Bi0<5KoZ}nh`BVGZW`cu93 ziBK#rGy(hy3g4@Fv8Pueg($ zhG&Xd#IT_t+64288_nR76g0{!t}_EY&t~@3ety9n`+53~q4(Ii*!UFHT=J=78b7+A z@9=BqGa)XUKc)fr;ifbkmq@HaKof`2p3CK)Cj9sB@A=LUYHR{Ly9OD|4yS3w0^t zg;OQV=toYc>9WL|Xa2NooPQR->@s@I=|r8Je|_0Fy&4~viZOZ0sp@6DVhW=|l|CJN zrG+nF#y`A_?wxE9GirwW#6e{$%U>zXvhe6~A)R*Oy7?^)YX9H|ctX^AvEm z>-H$qP=lwI>Ar`Kao6E>k{Kr>zm$C9y*pITp%^S=3HS7cH@n58GbPJ<>Bm(Q&^{!p z3jrQ_kHkLKE}KtBd-clrATAKDZ@Sqn5o1~hy;i-<^N5|rmLnI2>**1ntZ|{uoU8k2 zCaCGX3lkX__w>3vcLzuBTXtW7^Lw_l30%xJXWb3|9vnWfNk(H4)UONp-9DfIsq@y4lyzD$j@_z=)W3`f@Dj8Hj1MjOys9{LX>+*D%gZp5^oI z9Lc$pxz^hfaBGnn=1cEHRENGMR=C6}33kRsVm*so;tH4eHCH@R)nOT~00kp|Xg9W}^1Y_EQ;k;B-v+x(r-rTV4$5kED6FF@>q)w+-OhAb?QEBIRNrYCvv;oPaybDk z+ch@PwdUB%hK`X}@3x%$y#?cp9Ugr3>jw?SkwJse@y#xr1ZwMWBpFSPA_{(s_!y@9z|KjB?0E5}b*yq|sz{ z<*3}A!nTcngKZOzH#rnWXWGiqjJEL?+k{cWab?$-5?y|x?r>yx{&h~LbM9C!KaX`V zR2yY)wNiGAfpV`iP$$>3P0f@&fd!fE*#?Sja-`vDbmmjB_|91^AG_;AsA5hQyJ@ST zqvB%SHBqHYQS=@fdA30j)XcB`Uw+3gsxMamsrqE~aP>94toEY*q&}ne?V5}lzka%U zh5oUcuhkx|n^RX?XI=h{+Uv_lYoA$>P`A1ErP|-r-naa-+Pjv|Hk@9rs@+@r=i1>q zANO*DuVJ#GpthivtzBOG)9T6UKUDv<`h)6!>Tl`K>v?@jZKx)p4>SCv1hL^T8>4dNAJl)Uk#ynUv_l1 zpzkLQjuL(UfjD~gK<`8T(*`CJUQ8-*TcselWeOycDG(bQU!YE%tWn(Xyzfp<0wn)2 zG&u-OAyj}ThORf9`HBHYQ3wXsz<&<=eS(}}5?XC;Pe0+J^Bic;`?&ud zR74Cus|`m#KM|BqV?F$%T3`@=ZzJ!Q8`O(83F^O{6XegiF~^5op8jL1T7I^{@kRrG z!Vu-NxrkVWu%t9XJZ6Zw^0dYCz62hogI}{8 zq$deX!vj+KHtc+ILt)`QT8W`?iLxOAdo`K#hp6ZM1^ngZXXG`J=w#w&2bPnjI~(~w zHrjr#u714iZ1UL7;lXbz`hI!fz=8d^OhOHk{_%s!9bF!;`h>5yef!W4694j~>lX*g z_xWdMX9vEl8krw>5O9dfQtP!3ALKq6vtBtdaCC@z1B5QX2fLYOc6s~0yf<~Bq; z``FZZpUgIJwB!0+lY?&qSOVT38+SA={=v>oJ(k5!);yl@&A#m5tL6LVSODPK*z8jS zBF2B}U*kuwZCeqUx@X1YQ(@!r!KeRIZXh-m5H7GB#Byw_QSZ1zP~Vt$8x$@VvwQun zj7;bTb<$medfDd!uWsy94(by!>#%~5s4S6c<>(i?_7DAORz2{dz_$-fym_Ep8vp5k zktzbX6<`#_=|Q$Ym$0O6v-0^U|0GlqFa{|jy5yOe6`ot9K`!C7XI7~1y&g0Cz}bsD?l+ui=BWsGgC@CHUCwUjB&{5HrlJ=Y4ffx1b&yB`uYWa!OyQekNZ~ z|Ey1tKaB#t0wOO@aBQsu3UZnAUlV@U=i@c|zWdmb1N~LcKp1<^CPHIbwRgm;K81=MruxP&M|crQ1|DNjEu_q@+lA$E6!ZT0m= z`^49D`Qp!YrAx$sK7qS&ypaD}W0WA@8hM#Mcbbv1+emg0yQQhf0$iva&#g1MMz7}x zN6pJn^di{M!6=6OM`dgpH|_t1%r>*EekiJdw)>8lrcXYd27QO-D_i$W`0rMxfdg@7t{6gdet%vJzURb`Uhk-CV@*kte1D*-FqD3I5U6m5nV=v zO`P)8M+@iAoUi9}b3Z#%U%ePd_2*AH>gkC{hM8GdZPNDEPfgcXS82n>Y8^XQOl#$q z>l3xrx;t^Lrdn5Vr&bl!hTLEs1VVqziHqgb=npy3#8IOUb0l(UW0DUu2}fKnKdpR4 zVknzyW)(+hM|79?i9QVnN|7U4Aj*}+lab?P^m%8iGQqEf-csNp z!+~JqV+}`KC+(bLtbynuABQJV0{v0$6{y09l5*JuA5m~&tM^|Cx3DCLE7#IFUpm13 z=mEOrtTgK;ys@JVZo#EsHDxF%wrEVz%mTS!@$R$Y;Y@%FIEuH zA$0`wVQ`46pD1sM$~I!U1(}RW6~>(8Wp~>Ik5h2>t!zbTS#a|YGzuQtlczYS5Hf~w zZ31|Z9wrB;8@~+NAuN#wyU0;4Zg2r{M2NkM@NDD1qh@>oO8O2D<7Ck=5X}?Z{RjHz z-OyczV7MBPnNm0Q&vPf^SXCpxp8P0;JdnXHz+XTEHz~iTaa{VXYaEyGb7%b9K)Max z_X+rM#}$h|AjLFDqJuW3|ioaWa#sCIA@OicuCa`De75fD%5yHpI@h_1Gg+~)Fmqj@Cw+pjG1$d zalY}qi--?`{P4I0{OFQXh43mt3RJ{Bsk*Du>Dd{2S&xZR@eYTQ2{ zPJ)9o#CyxorDRI|W!7CKd?0w#cx3!vZrcCtwh1TiH{2d8!?Ddk_7MgBmAZ_0pJVY3 z-4G(Em~l}@QhqJ&tX!AYZ!Uj@8z+e2oq>qb`#;=0_Yk>0)3XCNL;1&BK3UNcq?4Td zDPxF#)X2=?j^e9v%Z^PC?&{gm$2`1y>sE@dGlK1#CfEesH9M!`RmQqu&V_o-xPQ9o z_QlqHHYUB$bMLT^-`eD*qrAh&s2qPXY93hS`G)7EA_WRuLwhRrXiBL(tWQVkjG8y7 zy!a6x<^VasL;t1*yGk~eUB4WSo&wWuY{uC%U4;HMxpz^p65##|)(4EteC{-0Xu-`$ z=`QfYJ-fF(MDgiHG+Yx0SQoKJ`8%5;4Y;Ls${0EIsPW7LMmK+{$t6$GtY0-y@fWtR zLUn^97mB)Z^Y-x#+xnQE?VGkS52M$exY%~ijN@v(1X6PE?`xD#R)W}H2p9dmt$e7t z*TEP0g01}P#$Gv9v0dBYIpPuT)CN=c1V%433j3FxPcP(51q2v|^77_fxgbA^G4Qt?HJ& z#tl*d55Vy=Bd6gP8kq!}o0}zbOa7dNNxHLqI~-}jpTsCBC9y+9{-g#hU}dwo^fJiTR}5gUy%>^Kgsq-@oQ256etWjE0p|}gl#EvF zXXN}G6P?t@H@9ZzsJ!T|oShLD%a}w!#o8;pvOx+rR)=w39DgSR&M9CSKxI*s(xlg%X+1f)*_4W zdl@eAwYPxP)mtf91}GRnIi^oJ4+OwLYbLo5^LLdKZXnasN(Z^Q))GE5)T;)wTYBg)=T;^q>rW22{d zmt?q^U^+svlMj%Yei}!)aV8DZ?HLFtvzfm+2@=Y@Th%Sc4bT^I1;@alPvFXVZ>u~J z=bpw}?W$x%cIh{q@?_+Hz7pr4=$`|IeUphxA6n%eqHl6C8C=RB|6o(V4lG?zK?j#U zuxbHO7XASC%WdHuwM>@mtFx&%bX(lH>Sl;v((J!D`IPv;_~d%GoYAaHaQsiJG?kV( zhWl(p`~Ah`nRYkb+cP-EDHDx2`m`kF9RS zpD-91YC^O~Y{8$3I5k&>KVo1oJCz8ReM}yRV|`)5-!pJhOdf%Ha%#PX>Tqi;tL_@r zt_13~s|50+_{%WWb9@~6voi~gUfe6p0oxa_>y~a<<@UE+!_KMr6!tvN4I_2h;N}!= zv|XT23x+ph-!m|d6X3pJkwUToQ0AWF(K8P=MTqtYYBsDIsHX6zY+x|5W!^Edpk_Eo zDn5xz7-GPU!-ebl(v|$1D{+93bn98qs`iP@c=^UvJ1bqq8&|oDxaAM6I-V#dGAYk; z3GnpgfRc2vmP;O4X!LZrJTL7lQb-q~JRg%jt|VbfrG$zk;Nm63drtMdf&z5?0hhUF z^a^b5A%fAl)r>pyyv9q=E$fnr>sP@M>`^dFr)F^%U8`&IwZTkKl@ zQIY+c|7Z*~L`L_pm^nOv;k2i5vdw$sSiwr^3OBiGJ=6p2-yME$Slzlxo|J!-98bz2 zYAHcAHPmYEQLkPVg5m=q&bn(VtJwQE1v;u416#9S>Ao)~zaTpYf_B~OC~8{=xF=P6 z8SOeQ^XOi-u)9c%=42P_`=B77xgOb5$0 & Z-flag reset indicates EOF. +; Carry = 0 +; Destroys: A,F +; +;BDOS1 - CP/M BDOS call. +; Inputs: A = function number +; DE = parameter +; Outputs: AF = result (carry=0) +; Destroys: A,F +; +READ: CALL SETDMA + LD A,33 +BDOS1: CALL BDOS0 ;* + JR NZ,CPMERR ;* + OR A ;* + RET ;* +CPMERR: LD A,255 ;* CP/M 3 + CALL EXTERR ;* BDOS ERROR + DEFM 'CP/M Error' ;* + DEFB 0 ;* +; +BDOS0: PUSH BC + PUSH DE + PUSH HL + PUSH IX + PUSH IY + LD C,A + CALL BDOS + INC H ;* TEST H + DEC H ;* CP/M 3 ONLY + POP IY + POP IX + POP HL + POP DE + POP BC + RET +; +;WRITE - Write a record to a disk file. +; Inputs: DE addresses FCB. +; HL = address to get data. +; Destroys: A,F +; +WRITE: CALL SETDMA + LD A,40 + CALL BDOS1 + JR Z,INCSEC + LD A,198 + CALL EXTERR + DEFM 'Disk full' + DEFB 0 +; +;INCSEC - Increment random record number. +; Inputs: DE addresses FCB. +; Destroys: F +; +INCSEC: PUSH HL + LD HL,33 + ADD HL,DE +INCS1: INC (HL) + INC HL + JR Z,INCS1 + POP HL + RET +; +;OPEN - Open a file for access. +; Inputs: FCB set up. +; Outputs: DE = FCB +; A=0 & Z-flag set indicates Not Found. +; Carry = 0 +; Destroys: A,D,E,F +; +OPEN: LD DE,FCB + LD A,15 + CALL BDOS1 + INC A + RET +; +;CREATE - Create a disk file for writing. +; Inputs: FCB set up. +; Outputs: DE = FCB +; A=0 & Z-flag set indicates directory full. +; Carry = 0 +; Destroys: A,D,E,F +; +CREATE: CALL CHKAMB + LD DE,FCB + LD A,19 + CALL BDOS1 ;DELETE + LD A,22 + CALL BDOS1 ;MAKE + INC A + RET +; +;CHKAMB - Check for ambiguous filename. +; Destroys: A,D,E,F +; +CHKAMB: PUSH BC + LD DE,FCB + LD B,12 +CHKAM1: LD A,(DE) + CP '?' + JR Z,AMBIG ;AMBIGUOUS + INC DE + DJNZ CHKAM1 + POP BC + RET +AMBIG: LD A,204 + CALL EXTERR + DEFM 'Bad name' + DEFB 0 +; +;SETDMA - Set "DMA" address. +; Inputs: HL = address +; Destroys: A,F +; +SETDMA: LD A,26 + EX DE,HL + CALL BDOS0 + EX DE,HL + RET +; +;FIND - Find file parameters from channel. +; Inputs: E = channel +; Outputs: DE addresses FCB +; HL addresses pointer byte (FCB+37) +; Destroys: A,D,E,H,L,F +; +FIND: INC E ;N.B. channel 8 is SPOOL/EXEC + DEC E + JR Z,CHANER + CALL FIND1 + LD HL,37 + ADD HL,DE + RET NZ +CHANER: LD A,222 + CALL EXTERR + DEFM 'Invalid channel' + DEFB 0 +; +;FIND1 - Look up file table. +; Inputs: E = channel +; Outputs: Z-flag set = file not opened +; If NZ, DE addresses FCB +; HL points into table +; Destroys: A,D,E,H,L,F +; +FIND1: LD A,E + AND 7 + ADD A,A + LD E,A + LD D,0 + LD HL,TABLE + ADD HL,DE + LD E,(HL) + INC HL + LD D,(HL) + LD A,D + OR E + RET +; +;SETUP - Set up File Control Block. +; Inputs: HL addresses filename +; Format [A:]FILENAME[.EXT] +; Device defaults to current drive +; Extension defaults to .BBC +; A = fill character +; Outputs: HL updated +; A = terminator +; BC = 128 +; Destroys: A,B,C,H,L,F +; +;FCB FORMAT (36 BYTES TOTAL): +; 0 0=SAME DISK, 1=DISK A, 2=DISK B (ETC.) +; 1-8 FILENAME, PADDED WITH SPACES +; 9-11 EXTENSION, PADDED WITH SPACES +; 12 CURRENT EXTENT, SET TO ZERO +; 32-35 CLEARED TO ZERO +; +SETUP0: LD A,' ' +SETUP: PUSH DE + PUSH HL + LD DE,FCB+9 + LD HL,BBC + LD BC,3 + LDIR + LD HL,FCB+32 + LD B,4 +SETUP1: LD (HL),C + INC HL + DJNZ SETUP1 + POP HL + LD C,A + XOR A + LD (DE),A + POP DE + CALL SKIPSP + CP '"' + JR NZ,SETUP2 + INC HL + CALL SKIPSP + CALL SETUP2 + CP '"' + INC HL + JR Z,SKIPSP +BADSTR: LD A,253 + CALL EXTERR + DEFM 'Bad string' + DEFB 0 +; +PARSE: LD A,(HL) + INC HL + CP '`' + RET NC + CP '?' + RET C + XOR 40H + RET +; +SETUP2: PUSH DE + INC HL + LD A,(HL) + CP ':' + DEC HL + LD A,B + JR NZ,DEVICE + LD A,(HL) ;DRIVE + AND 31 + INC HL + INC HL +DEVICE: LD DE,FCB + LD (DE),A + INC DE + LD B,8 +COPYF: LD A,(HL) + CP '.' + JR Z,COPYF1 + CP ' ' + JR Z,COPYF1 + CP CR + JR Z,COPYF1 + CP '=' + JR Z,COPYF1 + CP '"' + JR Z,COPYF1 + LD C,'?' + CP '*' + JR Z,COPYF1 + LD C,' ' + INC HL + CP '|' + JR NZ,COPYF2 + CALL PARSE + JR COPYF0 +COPYF1: LD A,C +COPYF2: CALL UPPRC +COPYF0: LD (DE),A + INC DE + DJNZ COPYF +COPYF3: LD A,(HL) + INC HL + CP '*' + JR Z,COPYF3 + CP '.' + LD BC,3*256+' ' + LD DE,FCB+9 + JR Z,COPYF + DEC HL + POP DE + LD BC,128 +SKIPSP: LD A,(HL) + CP ' ' + RET NZ + INC HL + JR SKIPSP +; +BBC: DEFM 'BBC' +; +;HEX - Read a hex string and convert to binary. +; Inputs: HL = text pointer +; Outputs: HL = updated text pointer +; DE = value +; A = terminator (spaces skipped) +; Destroys: A,D,E,H,L,F +; +HEX: LD DE,0 ;INITIALISE + CALL SKIPSP +HEX1: LD A,(HL) + CALL UPPRC + CP '0' + JR C,SKIPSP + CP '9'+1 + JR C,HEX2 + CP 'A' + JR C,SKIPSP + CP 'F'+1 + JR NC,SKIPSP + SUB 7 +HEX2: AND 0FH + EX DE,HL + ADD HL,HL + ADD HL,HL + ADD HL,HL + ADD HL,HL + EX DE,HL + OR E + LD E,A + INC HL + JR HEX1 +; +;OSCLI - Process an "operating system" command +; +OSCLI: CALL SKIPSP + CP CR + RET Z + CP '|' + RET Z + CP '.' + JP Z,DOT ;*. + EX DE,HL + LD HL,COMDS +OSCLI0: LD A,(DE) + CALL UPPRC + CP (HL) + JR Z,OSCLI2 + JR C,HUH +OSCLI1: BIT 7,(HL) + INC HL + JR Z,OSCLI1 + INC HL + INC HL + JR OSCLI0 +; +OSCLI2: PUSH DE +OSCLI3: INC DE + INC HL + LD A,(DE) + CALL UPPRC + CP '.' ;ABBREVIATED? + JR Z,OSCLI4 + XOR (HL) + JR Z,OSCLI3 + CP 80H + JR Z,OSCLI4 + POP DE + JR OSCLI1 +; +OSCLI4: POP AF + INC DE +OSCLI5: BIT 7,(HL) + INC HL + JR Z,OSCLI5 + LD A,(HL) + INC HL + LD H,(HL) + LD L,A + PUSH HL + EX DE,HL + JP SKIPSP +; +; +ERA: CALL SETUP0 ;*ERA, *ERASE + LD C,19 + JR XEQ ;"DELETE" +; +RES: LD C,13 ;*RESET + JR XEQ ;"RESET" +; +DRV: CALL SETUP0 ;*DRIVE + LD A,(FCB) + DEC A + JP M,HUH + LD E,A + LD C,14 + JR XEQ0 +; +REN: CALL SETUP0 ;*REN, *RENAME + CP '=' + JR NZ,HUH + INC HL ;SKIP "=" + PUSH HL + CALL EXISTS + LD HL,FCB + LD DE,FCB+16 + LD BC,12 + LDIR + POP HL + CALL SETUP0 + CALL CHKAMB + LD C,23 +XEQ: LD DE,FCB +XEQ0: LD A,(HL) + CP CR + JR NZ,HUH +BDC: LD A,C + CALL BDOS1 + RET P +HUH: LD A,254 + CALL EXTERR + DEFM 'Bad command' + DEFB 0 +; +EXISTS: LD HL,DSKBUF + CALL SETDMA + LD DE,FCB + LD A,17 + CALL BDOS1 ;SEARCH + INC A + RET Z + LD A,196 + CALL EXTERR + DEFM 'File exists' + DEFB 0 +; +SAVLOD: CALL SETUP0 ;PART OF *SAVE, *LOAD + CALL HEX + CP '+' + PUSH AF + PUSH DE + JR NZ,SAVLO1 + INC HL +SAVLO1: CALL HEX + CP CR + JR NZ,HUH + EX DE,HL + POP DE + POP AF + RET Z + OR A + SBC HL,DE + RET NZ + JR HUH +; +DOT: INC HL +DIR: LD A,'?' ;*DIR + CALL SETUP + CP CR + JR NZ,HUH + LD C,17 +DIR0: LD B,4 +DIR1: CALL LTRAP + LD DE,FCB + LD HL,DSKBUF + CALL SETDMA + LD A,C + CALL BDOS1 ;SEARCH DIRECTORY + JP M,CRLF + RRCA + RRCA + RRCA + AND 60H + LD E,A + LD D,0 + LD HL,DSKBUF+1 + ADD HL,DE + PUSH HL + LD DE,8 ;** + ADD HL,DE + LD E,(HL) ;** + INC HL ;** + BIT 7,(HL) ;SYSTEM FILE? + POP HL + LD C,18 + JR NZ,DIR1 + PUSH BC + LD A,(FCB) + DEC A + LD C,25 + CALL M,BDC + ADD A,'A' + CALL OSWRCH + LD B,8 + LD A,' ' ;** + BIT 7,E ;** READ ONLY? + JR Z,DIR3 ;** + LD A,'*' ;** +DIR3: CALL CPTEXT + LD B,3 + LD A,' ' ;** + CALL SPTEXT + POP BC + DJNZ DIR2 + CALL CRLF + JR DIR0 +; +DIR2: PUSH BC + LD B,5 +PAD: LD A,' ' + CALL OSWRCH + DJNZ PAD + POP BC + JR DIR1 +; +OPT: CALL HEX ;*OPT + LD A,E + AND 3 +SETOPT: LD (OPTVAL),A + RET +; +RESET: XOR A + JR SETOPT +; +EXEC: LD A,00000001B ;*EXEC + DEFB 1 ;SKIP 2 BYTES (LD BC) +SPOOL: LD A,00000010B ;*SPOOL + PUSH AF + PUSH HL + CALL SESHUT ;STOP SPOOL/EXEC + POP HL + POP BC + LD A,(HL) + CP CR ;JUST SHUT? + RET Z + LD A,(FLAGS) + OR B + LD (FLAGS),A ;SPOOL/EXEC FLAG + RRA ;CARRY=1 FOR EXEC + CALL OPENIT ;OPEN SPOOL/EXEC FILE + RET Z ;DIR FULL / NOT FOUND + POP IX ;RETURN ADDRESS + LD HL,(HIMEM) + OR A + SBC HL,SP ;SP=HIMEM? + ADD HL,SP + JR NZ,JPIX ;ABORT + LD BC,-FCBSIZ + ADD HL,BC ;HL=HL-FCBSIZ + LD (HIMEM),HL ;NEW HIMEM + LD (TABLE),HL ;FCB/BUFFER + LD SP,HL ;NEW SP + EX DE,HL + CALL OPEN3 ;FINISH OPEN OPERATION +JPIX: JP (IX) ;"RETURN" +; +UPPRC: AND 7FH + CP '`' + RET C + AND 5FH ;CONVERT TO UPPER CASE + RET +; +HELP: LD B,32 + LD HL,VERMSG + JP PTEXT +; +;*ESC COMMAND +; +ESCCTL: LD A,(HL) + CALL UPPRC ;** + CP 'O' + JR NZ,ESCC1 + INC HL +ESCC1: CALL HEX + LD A,E + OR A + LD HL,FLAGS + RES 6,(HL) ;ENABLE ESCAPE + RET Z + SET 6,(HL) ;DISABLE ESCAPE + RET +; +; +COMDS: DEFM 'BY' + DEFB 'E'+80H + DEFW BYE + DEFM 'DI' + DEFB 'R'+80H + DEFW DIR + DEFM 'DRIV' + DEFB 'E'+80H + DEFW DRV + DEFM 'ERAS' + DEFB 'E'+80H + DEFW ERA + DEFM 'ER' + DEFB 'A'+80H + DEFW ERA + DEFM 'ES' + DEFB 'C'+80H + DEFW ESCCTL + DEFM 'EXE' + DEFB 'C'+80H + DEFW EXEC + DEFM 'HEL' + DEFB 'P'+80H + DEFW HELP + DEFM 'LOA' + DEFB 'D'+80H + DEFW STLOAD + DEFM 'OP' + DEFB 'T'+80H + DEFW OPT + DEFM 'QUI' + DEFB 'T'+80H + DEFW BYE + DEFM 'RENAM' + DEFB 'E'+80H + DEFW REN + DEFM 'RE' + DEFB 'N'+80H + DEFW REN + DEFM 'RESE' + DEFB 'T'+80H + DEFW RES + DEFM 'SAV' + DEFB 'E'+80H + DEFW STSAVE + DEFM 'SPOO' + DEFB 'L'+80H + DEFW SPOOL + DEFM 'TYP' + DEFB 'E'+80H + DEFW TYPE + DEFB 0FFH +; +;PTEXT - Print text +; Inputs: HL = address of text +; B = number of characters to print +; Destroys: A,B,H,L,F +; +CPTEXT: PUSH AF ;** + LD A,':' + CALL OSWRCH + POP AF ;** +SPTEXT: CALL OSWRCH ;** +PTEXT: LD A,(HL) + AND 7FH + INC HL + CALL OSWRCH + DJNZ PTEXT + RET +; +;OSINIT - Initialise RAM mapping etc. +;If BASIC is entered by BBCBASIC FILENAME then file +;FILENAME.BBC is automatically CHAINed. +; Outputs: DE = initial value of HIMEM (top of RAM) +; HL = initial value of PAGE (user program) +; Z-flag reset indicates AUTO-RUN. +; Destroys: A,B,C,D,E,H,L,F +; +OSINIT: LD C,45 ;* + LD E,254 ;* + CALL BDOS ;* + XOR A + LD B,INILEN + LD HL,TABLE +CLRTAB: LD (HL),A ;CLEAR FILE TABLE ETC. + INC HL + DJNZ CLRTAB + LD DE,ACCS + LD HL,DSKBUF + LD C,(HL) + INC HL + CP C ;N.B. A=B=0 + JR Z,NOBOOT + LDIR ;COPY TO ACCS +NOBOOT: EX DE,HL + LD (HL),CR + LD DE,(6) ;DE = HIMEM + LD E,A ;PAGE BOUNDARY + LD HL,USER + RET +; +; +;TRAP - Test ESCAPE flag and abort if set; +; every 20th call, test for keypress. +; Destroys: A,H,L,F +; +;LTRAP - Test ESCAPE flag and abort if set. +; Destroys: A,F +; +TRAP: LD HL,TRPCNT + DEC (HL) + CALL Z,TEST20 ;TEST KEYBOARD +LTRAP: LD A,(FLAGS) ;ESCAPE FLAG + OR A ;TEST + RET P +ABORT: LD HL,FLAGS ;ACKNOWLEDGE + RES 7,(HL) ;ESCAPE + JP ESCAPE ;AND ABORT +; +;TEST - Sample for ESCape and CTRL/S. If ESCape +; pressed set ESCAPE flag and return. +; Destroys: A,F +; +TEST20: LD (HL),20 +TEST: PUSH DE + LD A,6 + LD E,0FFH + CALL BDOS0 + POP DE + OR A + RET Z + CP 'S' AND 1FH ;PAUSE DISPLAY? + JR Z,OSRDCH + CP ESC + JR Z,ESCSET + LD (INKEY),A + RET +; +;OSRDCH - Read from the current input stream (keyboard). +; Outputs: A = character +; Destroys: A,F +; +KEYGET: LD B,(IX-12) ;SCREEN WIDTH + CALL OSRDCH + CP DEL + JR Z,KEYDEL + CP 224 + RET NZ + CALL OSRDCH + SUB 65 + RET +; +KEYDEL: LD A,BS + RET +; +OSRDCH: LD A,(FLAGS) + RRA ;*EXEC ACTIVE? + JR C,EXECIN + PUSH HL + SBC HL,HL ;HL=0 + CALL OSKEY + POP HL + RET C + JR OSRDCH +; +;EXECIN - Read byte from EXEC file +; Outputs: A = byte read +; Destroys: A,F +; +EXECIN: PUSH BC ;SAVE REGISTERS + PUSH DE + PUSH HL + LD E,8 ;SPOOL/EXEC CHANNEL + LD HL,FLAGS + RES 0,(HL) + CALL OSBGET + SET 0,(HL) + PUSH AF + CALL C,SESHUT ;END EXEC IF EOF + POP AF + POP HL ;RESTORE REGISTERS + POP DE + POP BC + RET +; +; +;OSKEY - Read key with time-limit, test for ESCape. +;Main function is carried out in user patch. +; Inputs: HL = time limit (centiseconds) +; Outputs: Carry reset if time-out +; If carry set A = character +; Destroys: A,H,L,F +; +OSKEY: PUSH HL + LD HL,INKEY + LD A,(HL) + LD (HL),0 + POP HL + OR A + SCF + RET NZ + PUSH DE + CALL GETKEY + POP DE + RET NC + CP ESC + SCF + RET NZ +ESCSET: PUSH HL + LD HL,FLAGS + BIT 6,(HL) ;ESC DISABLED? + JR NZ,ESCDIS + SET 7,(HL) ;SET ESCAPE FLAG +ESCDIS: POP HL + RET +; +;OSWRCH - Write a character to console output. +; Inputs: A = character. +; Destroys: Nothing +; +OSWRCH: PUSH AF + PUSH DE + PUSH HL + LD E,A + CALL TEST + CALL EDPUT + POP HL + POP DE + POP AF + RET +; +EDPUT: LD A,(FLAGS) + BIT 3,A + JR Z,WRCH + LD A,E + CP ' ' + RET C + LD HL,(EDPTR) + LD (HL),E + INC L + RET Z + LD (EDPTR),HL + RET +; +PROMPT: LD E,'>' +WRCH: LD A,(OPTVAL) ;FAST ENTRY + ADD A,3 + CP 3 + JR NZ,WRCH1 + ADD A,E + LD A,2 + JR C,WRCH1 + LD A,6 +WRCH1: CALL BDOS0 + LD HL,FLAGS + BIT 2,(HL) + LD A,5 ;PRINTER O/P + CALL NZ,BDOS0 + BIT 1,(HL) ;SPOOLING? + RET Z + RES 1,(HL) + LD A,E ;BYTE TO WRITE + LD E,8 ;SPOOL/EXEC CHANNEL + PUSH BC + CALL OSBPUT + POP BC + SET 1,(HL) + RET +; +TOGGLE: LD A,(FLAGS) + XOR 00000100B + LD (FLAGS),A + RET +; +INSERT: LD A,(FLAGS) + XOR 00010000B + LD (FLAGS),A + RET +; +;OSLINE - Read/edit a complete line, terminated by CR. +; Inputs: HL addresses destination buffer. +; (L=0) +; Outputs: Buffer filled, terminated by CR. +; A=0. +; Destroys: A,B,C,D,E,H,L,F +; +OSLINE: LD IX,200H + LD A,(FLAGS) + BIT 3,A ;EDIT MODE? + JR Z,OSLIN1 + RES 3,A + LD (FLAGS),A + LD HL,(EDPTR) + CP L +OSLIN1: LD A,CR + LD (HL),A + CALL NZ,OSWRCH + LD L,0 + LD C,L ;REPEAT FLAG + JR Z,OSWAIT ;SUPPRESS UNWANTED SPACE +UPDATE: LD B,0 +UPD1: LD A,(HL) + INC B + INC HL + CP CR + PUSH AF + PUSH HL + LD E,A + CALL NZ,WRCH ;FAST WRCH + POP HL + POP AF + JR NZ,UPD1 + LD A,' ' + CALL OSWRCH + LD E,BS +UPD2: PUSH HL + CALL WRCH ;FAST WRCH + POP HL + DEC HL + DJNZ UPD2 +OSWAIT: LD A,C + DEC B + JR Z,LIMIT + OR A ;REPEAT COMMAND? +LIMIT: CALL Z,KEYGET ;READ KEYBOARD + LD C,A ;SAVE FOR REPEAT + LD DE,OSWAIT ;RETURN ADDRESS + PUSH DE + LD A,(FLAGS) + OR A ;TEST FOR ESCAPE + LD A,C + JP M,OSEXIT + CP (IX-11) ;CURSOR UP (IX-11) + JP Z,LEFT + CP (IX-10) ;CURSOR DOWN (IX-10) + JP Z,RIGHT + LD B,0 + CP (IX-5) ;CLEAR LEFT (IX-5) + JR Z,BACK + CP (IX-9) ;START OF LINE (IX-9) + JR Z,LEFT + CP (IX-7) ;CLEAR RIGHT (IX-7) + JR Z,DELETE + CP (IX-8) ;END OF LINE (IX-8) + JP Z,RIGHT + LD C,0 ;INHIBIT REPEAT + CP 'P' AND 1FH + JP Z,TOGGLE + CP (IX-1) ;INSERT / OVR (IX-1) + JP Z,INSERT + CP (IX-6) ;DELETE LEFT (IX-6) + JR Z,BACK + CP (IX-4) ;CURSOR LEFT (IX-4) + JR Z,LEFT + CP (IX-2) ;DELETE RIGHT (IX-2) + JR Z,DELETE + CP (IX-3) ;CURSOR RIGHT (IX-3) + JP Z,RIGHT + CP ' ' ;PRINTING CHARACTER + JR NC,SAVECH + CP CR ;ENTER LINE + RET NZ +OSEXIT: LD A,(HL) + CALL OSWRCH ;WRITE REST OF LINE + INC HL + SUB CR + JR NZ,OSEXIT + POP DE ;DITCH RETURN ADDRESS + CP C + JP NZ,ABORT ;ESCAPE + LD A,LF + CALL OSWRCH + LD DE,(CURLIN) + XOR A + LD L,A + LD (EDPTR),HL + CP D + RET NZ + CP E + RET NZ + LD DE,EDITST + LD B,4 +CMPARE: LD A,(DE) + CP (HL) + LD A,0 + RET NZ + INC HL + INC DE + LD A,(HL) + CP '.' + JR Z,ABBR + DJNZ CMPARE +ABBR: XOR A + LD B,A + LD C,L + LD L,A + LD DE,LISTST + EX DE,HL + LDIR + LD HL,FLAGS + SET 3,(HL) + RET +; +BACK: SCF ;DELETE LEFT +LEFT: INC L ;CURSOR LEFT + DEC L + JR Z,STOP + LD A,BS + CALL OSWRCH + DEC L + RET NC +DELETE: LD A,(HL) ;DELETE RIGHT + CP CR + JR Z,STOP + LD D,H + LD E,L +DEL1: INC DE + LD A,(DE) + DEC DE + LD (DE),A + INC DE + CP CR + JR NZ,DEL1 +DEL2: POP DE ;DITCH + JP UPDATE +; +SAVECH: LD D,A + LD A,(FLAGS) + AND 00010000B + LD A,D + JR NZ,RIGHT1 + LD D,A + LD A,CR ;INSERT SPACE + CP (HL) + LD A,D + JR Z,RIGHT1 + LD D,H + LD E,254 + PUSH AF +INS1: INC DE + LD (DE),A + DEC DE + LD A,E + CP L + DEC DE + LD A,(DE) + JR NZ,INS1 + POP AF + LD (HL),A + INC L + JR Z,WONTGO + CALL OSWRCH + JR DEL2 +; +RIGHT: LD A,(HL) ;CURSOR RIGHT + CP CR + JR Z,STOP +RIGHT1: LD D,(HL) ;PRINTING CHARACTER + LD (HL),A + INC L + JR Z,WONTGO ;LINE TOO LONG + CALL OSWRCH + LD A,CR + CP D + RET NZ + LD (HL),A + RET +; +WONTGO: DEC L + LD (HL),CR + LD A,BEL + CALL OSWRCH ;BEEP! +STOP: LD C,0 ;STOP REPEAT + RET +; +; +EDITST: DEFM 'EDIT' +LISTST: DEFM 'LIST' +; +BEL EQU 7 +BS EQU 8 +HT EQU 9 +LF EQU 0AH +VT EQU 0BH +CR EQU 0DH +ESC EQU 1BH +DEL EQU 7FH +; +BDOS EQU 5 +; +FCB EQU 5CH +DSKBUF EQU 80H +; +FCBSIZ EQU 128+36+2 +; +TRPCNT: DEFB 10 +TABLE: DEFS 16 ;FILE BLOCK POINTERS +FLAGS: DEFB 0 +INKEY: DEFB 0 +EDPTR: DEFW 0 +OPTVAL: DEFB 0 +INILEN EQU $-TABLE +; +FIN: END diff --git a/src/DATA.Z80 b/src/DATA.Z80 new file mode 100644 index 0000000..8b8816d --- /dev/null +++ b/src/DATA.Z80 @@ -0,0 +1,68 @@ + TITLE BBC BASIC (C) R.T.RUSSELL 1981-2024 +; +;RAM MODULE FOR BBC BASIC INTERPRETER +;FOR USE WITH VERSION 5.0 OF BBC BASIC +;(C) COPYRIGHT R.T.RUSSELL 1981-2024 +; + GLOBAL ACCS + GLOBAL BUFFER + GLOBAL ONERSP + GLOBAL LIBASE + GLOBAL PAGE + GLOBAL LOMEM + GLOBAL FREE + GLOBAL HIMEM + GLOBAL RANDOM + GLOBAL COUNT + GLOBAL WIDTH + GLOBAL ERL + GLOBAL ERR + GLOBAL ERRTRP + GLOBAL ERRTXT + GLOBAL TRACEN + GLOBAL AUTONO + GLOBAL INCREM + GLOBAL LISTON + GLOBAL DATPTR + GLOBAL FNPTR + GLOBAL PROPTR + GLOBAL STAVAR + GLOBAL OC + GLOBAL PC + GLOBAL DYNVAR + GLOBAL CURLIN + GLOBAL USER +; +;n.b. ACCS, BUFFER & STAVAR must be on page boundaries. +; +ACCS: DEFS 256 ;STRING ACCUMULATOR +BUFFER: DEFS 256 ;STRING INPUT BUFFER +STAVAR: DEFS 27*4 ;STATIC VARIABLES +OC EQU STAVAR+15*4 ;CODE ORIGIN (O%) +PC EQU STAVAR+16*4 ;PROGRAM COUNTER (P%) +DYNVAR: DEFS 54*2 ;DYN. VARIABLE POINTERS +FNPTR: DEFS 2 ;DYN. FUNCTION POINTER +PROPTR: DEFS 2 ;DYN. PROCEDURE POINTER +; +PAGE: DEFS 2 ;START OF USER PROGRAM +LOMEM: DEFS 2 ;START OF DYN. STORAGE +FREE: DEFS 2 ;FIRST FREE-SPACE BYTE +HIMEM: DEFS 2 ;FIRST BYTE ABOVE STACK +LIBASE: DEFS 2 ;START OF FIRST LIBRARY +; +TRACEN: DEFS 2 ;TRACE FLAG AND NUMBER +AUTONO: DEFS 2 ;AUTO FLAG AND NUMBER +ERRTRP: DEFS 2 ;ON ERROR STMT POINTER \ +ONERSP: DEFS 2 ;ON ERROR LOCAL STKPTR / +ERRTXT: DEFS 2 ;ERROR MESSAGE POINTER +DATPTR: DEFS 2 ;DATA POINTER +ERL: DEFS 2 ;LINE NO OF LAST ERROR +CURLIN: DEFS 2 ;POINTER TO CURRENT LINE +RANDOM: DEFS 5 ;RANDOM NUMBER +COUNT: DEFS 1 ;PRINT POSITION +WIDTH: DEFS 1 ;PRINT WIDTH +ERR: DEFS 1 ;ERROR NUMBER +LISTON: DEFS 1 ;LISTO & OPT FLAG +INCREM: DEFS 1 ;AUTO INCREMENT +; +USER: END diff --git a/src/DIST.Z80 b/src/DIST.Z80 new file mode 100644 index 0000000..bb37ffa --- /dev/null +++ b/src/DIST.Z80 @@ -0,0 +1,227 @@ + TITLE BBCDIST.Z80 (C) R.T.RUSSELL 1982-2024 +; +;BBC BASIC (Z80) - CP/M VERSION 2.20 & 3.00 +;(C) COPYRIGHT R.T.RUSSELL, 1982-2024. +;ALL RIGHTS RESERVED. +; +;THIS PROGRAM ALLOWS THE USER TO ADAPT BBC BASIC TO THE +;PARTICULAR CHARACTERISTICS OF HIS SYSTEM HARDWARE ETC. +; +;THE PROGRAM RESIDES AT 100H FOR EASE OF LOADING. +;*** IT MUST NOT EXCEED 256 BYTES IN TOTAL LENGTH *** +; +;PLEASE NOTE THAT A Z80 PROCESSOR AND CP/M VERSION 2.2 +;OR LATER ARE REQUIRED. +; +;R.T.RUSSELL, 11-03-1984, 03-05-1989, 12-05-2024 +; +CPM EQU 5 +COLD EQU 200H +; + GLOBAL CLRSCN + GLOBAL PUTCSR + GLOBAL GETCSR + GLOBAL PUTIME + GLOBAL GETIME + GLOBAL GETKEY + GLOBAL BYE +; + ASEG + ORG 100H +; +;JUMP TABLE - BASIC makes calls to hardware-dependent +;features via this table: +; + JP INIT +CLRSCN: JP CLS ;CLEAR SCREEN +PUTCSR: JP PCSR ;SET CURSOR POSN. +GETCSR: JP GCSR ;READ CURSOR POSN. +PUTIME: JP PTIME ;SET ELAPSED TIME +GETIME: JP GTIME ;READ ELAPSED TIME +GETKEY: JP INKEY ;READ KEY (TIME LIMIT) +BYE: JP REBOOT ;RETURN TO CP/M +; +;BDOS - Save the IX and IY registers and before performing a +; CP/M function call. +; +BDOS: PUSH IX + PUSH IY + CALL CPM + POP IY + POP IX + RET +; +;INIT - Perform hardware initialisation (if any). +; +INIT: LD A,2 + INC A + LD DE,NOTZ80 + JP PE,FAIL + LD C,12 + CALL BDOS + OR A + LD DE,NOTV2 + JP NZ,COLD +FAIL: LD C,9 + CALL BDOS + RST 0 +; +NOTZ80: DEFB 'Not a Z80$' +NOTV2: DEFB 'Not CP/M 2$' +; +;REBOOT - Switch off interrupts and return to CP/M +; +REBOOT: RST 0 +; +;GTIME - Read elapsed-time clock. +; Outputs: DEHL = elapsed time (centiseconds) +; Destroys: A,D,E,H,L,F +; +GTIME: PUSH BC + CALL TICKS + LD BC,(OFFLO) + ADD HL,BC + EX DE,HL + LD BC,(OFFHI) + ADC HL,BC + EX DE,HL + POP BC + RET +; +;PTIME - Load elapsed-time clock. +; Inputs: DEHL = time to load (centiseconds) +; Destroys: A,D,E,H,L,F +; +PTIME: PUSH BC + PUSH DE + PUSH HL + CALL TICKS + LD B,H + LD C,L + POP HL + OR A + SBC HL,BC + LD (OFFLO),HL + LD B,D + LD C,E + POP HL + SBC HL,BC + LD (OFFHI),HL + POP BC + RET +; +; Get OS elapsed-time clock +; Outputs: DEHL = time (centiseconds) +; Destroys: A,B,C,D,E,H,L,F +; +TICKS: LD C,248 ;RunCPM-specific function call + CALL BDOS + PUSH DE + EX DE,HL + OR A + SBC HL,HL + LD BC,-5 + LD A,32 +DIV0: ADD HL,BC + JR C,DIV1 + SBC HL,BC +DIV1: RL E + RL D + EX (SP),HL + RL L + RL H + EX (SP),HL + ADC HL,HL + DEC A + JR NZ,DIV0 + EX DE,HL + POP DE + RET +; +;INKEY - Sample keyboard with specified wait. +; Inputs: HL = Time to wait (centiseconds) +; Outputs: Carry reset indicates time-out. +; If carry set, A = character typed. +; Destroys: A,D,E,H,L,F +; +INKEY: PUSH BC + PUSH HL + CALL TICKS + POP DE + ADD HL,DE +WAIT: PUSH HL + LD C,6 + LD E,0FFH + CALL BDOS + POP HL + OR A + SCF + JR NZ,INKEY1 + PUSH HL + CALL TICKS + POP DE + SBC HL,DE + EX DE,HL + JR C,WAIT +INKEY1: POP BC + RET +; +;CLS - Clear screen. +; (Customise to suit your VDU) +; Destroys: A,D,E,H,L,F +; +CLS: RET +; +;PCSR - Move cursor to specified position. +; Inputs: DE = horizontal position (LHS=0) +; HL = vertical position (TOP=0) +; Destroys: A,D,E,H,L,F +; +PCSR: RET +; +;GCSR - Return cursor coordinates. +; Outputs: DE = X coordinate (POS) +; HL = Y coordinate (VPOS) +; Destroys: A,D,E,H,L,F +; +GCSR: LD DE,0 + LD HL,0 + RET +; +;COUT - Output a character to the console +; Inputs: A = character +; Destroys: A,F +; +COUT: PUSH BC + PUSH DE + PUSH HL + LD E,A + LD C,2 + CALL BDOS + POP HL + POP DE + POP BC + RET +; + IF $ GT 1F0H + ERROR 'INSUFFICIENT SPACE' + ENDIF +; + ORG 1F0H +; +OFFLO: DEFW 0 ;TIME OFFSET LO +OFFHI: DEFW 0 ;TIME OFFSET HI + DEFB 80 ;WIDTH + DEFB 'G' AND 1FH ;CURSOR UP + DEFB 'O' AND 1FH ;CURSOR DOWN + DEFB 'F' AND 1FH ;START OF LINE + DEFB 'N' AND 1FH ;END OF LINE + DEFB 'X' AND 1FH ;DELETE TO END OF LINE + DEFB 08H ;BACKSPACE & DELETE + DEFB 'U' AND 1FH ;DEL TO START OF LINE + DEFB 'J' AND 1FH ;CURSOR LEFT + DEFB 'L' AND 1FH ;CURSOR RIGHT + DEFB 'R' AND 1FH ;DELETE CHARACTER + DEFB 'Q' AND 1FH ;INS/OVR TOGGLE +; +FIN: END diff --git a/src/EVAL.Z80 b/src/EVAL.Z80 new file mode 100644 index 0000000..28b63d5 --- /dev/null +++ b/src/EVAL.Z80 @@ -0,0 +1,2586 @@ + TITLE BBC BASIC (C) R.T.RUSSELL 1981-2024 +; +;BBC BASIC INTERPRETER - Z80 VERSION +;EVALUATE EXPRESSION MODULE - "EVAL" +;(C) COPYRIGHT R.T.RUSSELL 1981-2024 +; +;THE NAME BBC BASIC IS USED WITH THE PERMISSION +;OF THE BRITISH BROADCASTING CORPORATION AND IS +;NOT TRANSFERRABLE TO A FORKED OR DERIVED WORK. +; +;VERSION 2.3, 07-05-1984 +;VERSION 3.0, 08-03-1987 +;VERSION 5.0, 14-05-2024 +; +;BINARY FLOATING POINT REPRESENTATION: +; 32 BIT SIGN-MAGNITUDE NORMALIZED MANTISSA +; 8 BIT EXCESS-128 SIGNED EXPONENT +; SIGN BIT REPLACES MANTISSA MSB (IMPLIED "1") +; MANTISSA=0 & EXPONENT=0 IMPLIES VALUE IS ZERO. +; +;BINARY INTEGER REPRESENTATION: +; 32 BIT 2'S-COMPLEMENT SIGNED INTEGER +; "EXPONENT" BYTE = 0 (WHEN PRESENT) +; +;NORMAL REGISTER ALLOCATION: MANTISSA - HLH'L' +; EXPONENT - C +; + GLOBAL EXPR + GLOBAL EXPRN + GLOBAL EXPRI + GLOBAL EXPRS + GLOBAL ITEMI + GLOBAL CONS + GLOBAL LOADS + GLOBAL VAL0 + GLOBAL SFIX + GLOBAL STR + GLOBAL HEXSTR + GLOBAL LOAD4 + GLOBAL LOADN + GLOBAL DLOAD5 + GLOBAL TEST + GLOBAL ZERO + GLOBAL COMMA + GLOBAL BRAKET + GLOBAL DECODE + GLOBAL PUSHS + GLOBAL POPS + GLOBAL SEARCH + GLOBAL SCP + GLOBAL LETARR +; + EXTRN MUL16 + EXTRN ERROR + EXTRN SYNTAX + EXTRN CHANEL + EXTRN CHNL + EXTRN STOREN + EXTRN STORE4 + EXTRN STORE5 + EXTRN STACCS + EXTRN CHECK + EXTRN USR + EXTRN VAR + EXTRN FN + EXTRN XEQ + EXTRN NXT + EXTRN X14OR5 + EXTRN MODIFY + EXTRN MODIFS + EXTRN TERMQ +; + EXTRN GETVAR + EXTRN LEXAN2 + EXTRN RANGE + EXTRN GETTOP +; + EXTRN STAVAR + EXTRN PAGE + EXTRN LOMEM + EXTRN HIMEM + EXTRN RANDOM + EXTRN COUNT + EXTRN LISTON + EXTRN PC + EXTRN ERL + EXTRN ERR + EXTRN ACCS + EXTRN ERRTXT + EXTRN KEYWDS + EXTRN KEYWDL + EXTRN FREE + EXTRN BUFFER +; + EXTRN OSRDCH + EXTRN OSOPEN + EXTRN OSBGET + EXTRN OSSTAT + EXTRN GETCSR + EXTRN GETIME + EXTRN GETIMS + EXTRN GETEXT + EXTRN GETPTR + EXTRN OSKEY +; + EXTRN POINT + EXTRN ADVAL + EXTRN TINTFN + EXTRN MODEFN + EXTRN WIDFN +; + EXTRN FPP +; +FUNTOK EQU 8DH ;1st FUNCTION TOKEN +TMOD EQU 83H +TLEN EQU 0A9H +TTO EQU 0B8H +TDIM EQU 0DEH +TEND EQU 0E0H +TMODE EQU 0EBH +TREPORT EQU 0F6H +TWIDTH EQU 0FEH +TTINT EQU 0AH +TBY EQU 0FH +; +;TABLE OF ADDRESSES FOR FUNCTIONS: +; +FUNTBL: DEFW DECODE ;Line number + DEFW OPENIN ;OPENIN + DEFW PTR ;PTR + DEFW PAGEV ;PAGE + DEFW TIMEV ;TIME + DEFW LOMEMV ;LOMEM + DEFW HIMEMV ;HIMEM + DEFW ABS ;ABS + DEFW ACS ;ACS + DEFW ADVAL ;ADVAL + DEFW ASC ;ASC + DEFW ASN ;ASN + DEFW ATN ;ATN + DEFW BGET ;BGET + DEFW COS ;COS + DEFW COUNTV ;COUNT + DEFW DEG ;DEG + DEFW ERLV ;ERL + DEFW ERRV ;ERR + DEFW EVAL ;EVAL + DEFW EXP ;EXP + DEFW EXT ;EXT + DEFW ZERO ;FALSE + DEFW FN ;FN + DEFW GET ;GET + DEFW INKEY ;INKEY + DEFW INSTR ;INSTR( + DEFW INT ;INT + DEFW LEN ;LEN + DEFW LN ;LN + DEFW LOG ;LOG + DEFW CPL ;NOT + DEFW OPENUP ;OPENUP + DEFW OPENOT ;OPENOUT + DEFW PI ;PI + DEFW POINT ;POINT( + DEFW POS ;POS + DEFW RAD ;RAD + DEFW RND ;RND + DEFW SGN ;SGN + DEFW SIN ;SIN + DEFW SQR ;SQR + DEFW TAN ;TAN + DEFW TOPV ;TO(P) + DEFW TRUE ;TRUE + DEFW USR ;USR + DEFW VAL ;VAL + DEFW VPOS ;VPOS + DEFW CHRS ;CHR$ + DEFW GETS ;GET$ + DEFW INKEYS ;INKEY$ + DEFW LEFTS ;LEFT$( + DEFW MIDS ;MID$( + DEFW RIGHTS ;RIGHT$( + DEFW STRS ;STR$ + DEFW STRING ;STRING$( + DEFW EOF ;EOF + DEFW SUM ;SUM +; +TCMD EQU FUNTOK+($-FUNTBL)/2 +; +CR EQU 0DH +LF EQU 0AH +AND EQU 80H +DIV EQU 81H +EOR EQU 82H +MOD EQU 83H +OR EQU 84H +; +SOPTBL: DEFW SLE ;<= (STRING) + DEFW SNE ;<> + DEFW SGE ;>= + DEFW SLT ;< + DEFW SEQ ;= + DEFW SGT ;> +; +;EXPR - VARIABLE-TYPE EXPRESSION EVALUATION +; Expression type is returned in A'F': +; Numeric - A' bit 7=0, F' sign bit cleared. +; String - A' bit 7=1, F' sign bit set. +;Floating-point or integer result returned in HLH'L'C +; Integer result denoted by C=0 and HLH'L' non-zero. +;String result returned in string accumulator, DE set. +; +;Hierarchy is: (1) Variables, functions, +; constants, bracketed expressions. +; (2) ^ +; (3) * / MOD DIV +; (4) + - +; (5) = <> <= >= > < +; (6) AND +; (7) EOR OR +; +EXPR: CALL EXPR1 ;GET FIRST OPERAND +EXPR0A: CP EOR ;CHECK OPERATOR + JR Z,EXPR0B + CP OR + RET NZ +EXPR0B: CALL SAVE ;SAVE FIRST OPERAND + CALL EXPR1 ;GET SECOND OPERAND + CALL DOIT ;DO OPERATION + JR EXPR0A ;CONTINUE +; +EXPR1: CALL EXPR2 +EXPR1A: CP AND + RET NZ + CALL SAVE + CALL EXPR2 + CALL DOIT + JR EXPR1A +; +EXPR2: CALL EXPR3 + CALL RELOPQ + RET NZ + LD B,A + INC IY ;BUMP OVER OPERATOR + CALL NXT + CALL RELOPQ ;COMPOUND OPERATOR? + JR NZ,EXPR2B + INC IY + CP B + JR Z,SHIFT ;SHIFT OR == + ADD A,B + LD B,A +EXPR2B: LD A,B + EX AF,AF' + JP M,EXPR2S + EX AF,AF' + SUB 4 + CP '>'-4 + JR NZ,EXPR2C + ADD A,2 +EXPR2C: AND 0FH +EXPR2D: CALL SAVE1 + CALL EXPR3 + CALL DOIT ;Must NOT be "JP DOIT" + RET +; +SHIFT: CP '=' + JR Z,EXPR2B ;== + CALL NXT + CALL RELOPQ + JR NZ,SHIFT1 + CP B + JP NZ,SYNTAX + INC IY + INC B +SHIFT1: LD A,B + SUB 18 + JR EXPR2D +; +EXPR2S: EX AF,AF' + DEC A + AND 7 + CALL PUSHS ;SAVE STRING ON STACK + PUSH AF ;SAVE OPERATOR + CALL EXPR3 ;SECOND STRING + EX AF,AF' + JP P,MISMAT + POP AF + LD C,E ;LENGTH OF STRING #2 + POP DE + LD HL,0 + ADD HL,SP + LD B,E ;LENGTH OF STRING #1 + PUSH DE + LD DE,ACCS + EX DE,HL + CALL DISPT2 + POP DE + EX DE,HL + LD H,0 + ADD HL,SP + LD SP,HL + EX DE,HL + XOR A ;NUMERIC MARKER + LD C,A ;INTEGER MARKER + EX AF,AF' + LD A,(IY) + RET +; +EXPR3: CALL EXPR4 +EXPR3A: CP '-' + JR Z,EXPR3B + CP '+' + RET NZ + EX AF,AF' + JP M,EXPR3S + EX AF,AF' +EXPR3B: CALL SAVE + CALL EXPR4 + CALL DOIT + JR EXPR3A +; +EXPR3S: EX AF,AF' + INC IY ;BUMP PAST '+' + CALL PUSHS ;SAVE STRING ON STACK + CALL EXPR4 ;SECOND STRING + EX AF,AF' + JP P,MISMAT + LD C,E ;C=LENGTH + POP DE + PUSH DE + LD HL,ACCS + LD D,H + LD A,C + OR A + JR Z,EXP3S3 + LD B,L + LD L,A ;SOURCE + ADD A,E + LD E,A ;DESTINATION + LD A,19 + JR C,ERROR2 ;"String too long" + PUSH DE + DEC E + DEC L + LDDR ;COPY + POP DE +EXP3S3: EXX + POP BC + CALL POPS ;RESTORE FROM STACK + EXX + OR 80H ;FLAG STRING + EX AF,AF' + LD A,(IY) + JR EXPR3A +; +EXPR4: CALL EXPR5 +EXPR4A: CP '*' + JR Z,EXPR4B + CP '/' + JR Z,EXPR4B + CP MOD + JR Z,EXPR4B + CP DIV + RET NZ +EXPR4B: CALL SAVE + CALL EXPR5 + CALL DOIT + JR EXPR4A +; +EXPR5: CALL ITEM + OR A ;TEST TYPE + EX AF,AF' ;SAVE TYPE +EXPR5A: CALL NXT + CP '^' + RET NZ + CALL SAVE + CALL ITEM + OR A + EX AF,AF' + CALL DOIT + JR EXPR5A +; +EXPRN: CALL EXPR + EX AF,AF' + RET P + JR MISMAT +; +EXPRI: CALL EXPR + EX AF,AF' + JP P,SFIX + JR MISMAT +; +EXPRS: CALL EXPR + EX AF,AF' + RET M + JR MISMAT +; +NEGATE: EXX + LD A,H + CPL + LD H,A + LD A,L + CPL + LD L,A + EXX + LD A,H + CPL + LD H,A + LD A,L + CPL + LD L,A +ADD1: EXX + INC HL + LD A,H + OR L + EXX + LD A,0 ;NUMERIC MARKER + RET NZ + INC HL + RET +; +BADHEX: LD A,28 +ERROR2: JP ERROR ;"Bad HEX or binary" +; +ITEMI: CALL ITEM + OR A + JP P,SFIX + JR MISMAT +; +ITEMS: CALL ITEM + OR A + RET M +MISMAT: LD A,6 + JR ERROR2 ;"Type mismatch" +; +ITEM1: CALL EXPR ;BRACKETED EXPR + CALL BRAKET + EX AF,AF' + RET +; +ITEMN: CALL ITEM + OR A + RET P + JR MISMAT +; +;HEX - Get hexadecimal constant. +; Inputs: ASCII string at (IY) +; Outputs: Integer result in H'L'HL, C=0, A7=0. +; IY updated (points to delimiter) +; +HEX: CALL ZERO + CALL HEXDIG + JR C,BADHEX +HEX1: INC IY + AND 0FH + LD B,4 +HEX2: EXX + ADD HL,HL + EXX + ADC HL,HL + DJNZ HEX2 + EXX + OR L + LD L,A + EXX + CALL HEXDIG + JR NC,HEX1 + XOR A + RET +; +;BIN - Get binary constant. +; Inputs: ASCII string at (IY) +; Outputs: Integer result in H'L'HL, C=0, A=0. +; IY updated (points to delimiter) +; +BIN: CALL ZERO + CALL BINDIG + JR C,BADHEX +BIN1: INC IY + RR A + EXX + ADC HL,HL + EXX + ADC HL,HL + CALL BINDIG + JR NC,BIN1 + XOR A + RET +; +;MINUS - Unary minus. +; Inputs: IY = text pointer +; Outputs: Numeric result, same type as argument. +; Result in H'L'HLC +; +MINUS: CALL ITEMN +MINUS0: DEC C + INC C + JR Z,NEGATE ;ZERO/INTEGER + LD A,H + XOR 80H ;CHANGE SIGN (FP) + LD H,A + XOR A ;NUMERIC MARKER + RET +; +ADDROF: CALL VAR + PUSH HL + EXX + POP HL + JP COUNT1 +; +;ITEM - VARIABLE TYPE NUMERIC OR STRING ITEM. +;Item type is returned in A: Bit 7=0 numeric. +; Bit 7=1 string. +;Numeric item returned in HLH'L'C. +;String item returned in string accumulator, +; DE addresses byte after last (E=length). +; +ITEM: CALL CHECK + CALL NXT + INC IY + CP FUNTOK + JR C,ITEM0 + CP TCMD + JP C,DISPAT ;FUNCTIONS + JP EXTRAS ;DIM, END, MODE, REPORT$, WIDTH +; +ITEM0: CP ':' + JR NC,ITEM2 ;VARIABLES + CP '0' + JR NC,CON ;NUMERIC CONSTANT + CP '(' + JR Z,ITEM1 ;EXPRESSION + CP '-' + JR Z,MINUS ;UNARY MINUS + CP '+' + JR Z,ITEMN ;UNARY PLUS + CP '.' + JR Z,CON ;NUMERIC CONSTANT + CP '&' + JR Z,HEX ;HEX CONSTANT + CP '%' + JR Z,BIN ;BINARY CONSTANT + CP '"' + JR Z,CONS ;STRING CONSTANT + CP TTINT + JP Z,TINT ;TINT FUNCTION +ITEM2: CP TMOD + JP Z,MODFUN ;MOD + CP '^' + JR Z,ADDROF ;^ OPERATOR + DEC IY + CALL GETVAR ;VARIABLE + JR NZ,NOSUCH + BIT 6,A + JR NZ,ARRAY + OR A + JP M,LOADS ;STRING VARIABLE +LOADN: BIT 2,A + LD C,0 + JR Z,LOAD1 ;BYTE VARIABLE + BIT 0,A + JR Z,LOAD4 ;INTEGER VARIABLE +LOAD5: LD C,(IX+4) +LOAD4: EXX + LD L,(IX+0) + LD H,(IX+1) + EXX + LD L,(IX+2) + LD H,(IX+3) + RET +; +LOAD1: LD HL,0 + EXX + LD H,0 + LD L,(IX+0) + EXX + RET +; +NOSUCH: JP C,SYNTAX + LD A,(LISTON) + BIT 5,A + LD A,26 + JR NZ,ERROR0 ;"No such variable" +NOS1: INC IY + CALL RANGE + JR NC,NOS1 + LD IX,PC + XOR A + LD C,A + JR LOAD4 +; +;CON - Get unsigned numeric constant from ASCII string. +; Inputs: ASCII string at (IY-1) +; Outputs: Variable-type result in HLH'L'C +; IY updated (points to delimiter) +; A7 = 0 (numeric marker) +; +CON: DEC IY + PUSH IY + POP IX + LD A,36 + CALL FPP + JR C,ERROR0 + PUSH IX + POP IY + XOR A + RET +; +;CONS - Get string constant from ASCII string. +; Inputs: ASCII string at (IY) +; Outputs: Result in string accumulator. +; D = MS byte of ACCS, E = string length +; A7 = 1 (string marker) +; IY updated +; +CONS: LD DE,ACCS +CONS3: LD A,(IY) + INC IY + CP '"' + JR Z,CONS2 +CONS1: LD (DE),A + INC E + CP CR + JR NZ,CONS3 + LD A,9 +ERROR0: JP ERROR ;"Missing """ +; +CONS2: LD A,(IY) + CP '"' + INC IY + JR Z,CONS1 + DEC IY + LD A,80H ;STRING MARKER + RET +; +ARRAY: LD A,14 ;'Bad use of array' + JP ERROR +; +; ARRLEN - Get start address and number of elements of an array +; Inputs: HL addresses array descriptor +; Outputs: HL = address of first element +; DE = total number of elements +; A = 0 +; Destroys: A,B,C,D,E,H,L,flags +; +ARRLEN: LD A,(HL) ;Number of dimensions + INC HL + OR A + JR Z,ARRAY + LD DE,1 +ARLOOP: LD C,(HL) + INC HL + LD B,(HL) ;BC = size of this dimension + INC HL + EX DE,HL + PUSH AF + PUSH DE + CALL MUL16 ;HL=HL*BC + POP DE + POP AF + EX DE,HL + DEC A + JR NZ,ARLOOP + RET +; +GETARR: CALL NXT + CALL GETVAR + JR NZ,NOSUCH + BIT 6,A + SCF + JR Z,NOSUCH + AND 8FH + LD B,A ;Type + size +GETAR1: LD A,(HL) + INC HL + LD H,(HL) + LD L,A + AND 0FEH + OR H + JR Z,ARRAY ;Bad use of array + RET +; +GETARB: CALL NXT + CP '(' + JR NZ,GETARR + INC IY + CALL GETARR + CALL BRAKET + RET +; +DLOADN: BIT 2,A + LD B,0 + JR Z,DLOAD1 ;BYTE VARIABLE + BIT 0,A + JR Z,DLOAD4 ;INTEGER VARIABLE +DLOAD5: LD B,(IX+4) +DLOAD4: EXX + LD E,(IX+0) + LD D,(IX+1) + EXX + LD E,(IX+2) + LD D,(IX+3) + RET +; +DLOAD1: LD DE,0 + EXX + LD D,0 + LD E,(IX+0) + EXX + RET +; +LOADS: LD DE,ACCS + RRA + JR NC,LOADS2 ;FIXED STRING + CALL LOAD4 + EXX + LD A,L + EXX + OR A + LD C,A + LD A,80H ;STRING MARKER + RET Z + LD B,0 + LDIR + RET +; +LOADS2: LD A,(HL) + LD (DE),A + INC HL + CP CR +REPDUN: LD A,80H ;STRING MARKER + RET Z + INC E + JR NZ,LOADS2 + RET ;RETURN NULL STRING +; +; Version 5 extensions: +; +EXTRAS: CP TMODE + JP Z,MODEFN ;MODE + CP TWIDTH + JP Z,WIDFN ;WIDTH + CP TREPORT + JR Z,REPORS ;REPORT$ + CP TEND + JR Z,ENDFUN ;END + CP TDIM + JR Z,DIMFUN ;DIM +SYNERR: JP SYNTAX ; 'Syntax error' +; +; END (function) +; +ENDFUN: LD HL,(FREE) + JP COUNT1 +; +; REPORT$ +; +REPORS: LD A,(IY) + CP '$' + JR NZ,SYNERR + INC IY + LD HL,(ERRTXT) + LD DE,ACCS +REPCPY: LD A,(HL) + OR A + JR Z,REPDUN + LDI + CP 160 + JP PE,REPCPY + CP LF + JR Z,REPCPY + DEC E + PUSH HL + LD HL,KEYWDS + LD BC,KEYWDL + CPIR + LD B,160 + CP 145 + JP PE,REPTOK + INC B +REPTOK: LD A,(HL) + LDI + CP B + JP PE,REPTOK + POP HL + DEC E + JR REPCPY +; +; DIM(array()[,sub]) +; +DIMFUN: CALL NXT + CP '(' + JR NZ,DIMF0 + INC IY + CALL DIMF0 + CALL BRAKET + RET +; +DIMF0: CALL GETARR + PUSH HL + CALL NXT + LD E,0 + CP ',' + JR NZ,DIMF1 + INC IY + CALL EXPRI + EXX + EX DE,HL + INC E + DEC E + JR Z,BADSUB +DIMF1: POP HL + LD A,(HL) + INC HL + CP E + JR C,BADSUB + DEC E + JP M,DIMF3 + ADD HL,DE + ADD HL,DE + LD A,(HL) + INC HL + LD H,(HL) + LD L,A + DEC HL +DIMF2: JP COUNT1 + +DIMF3: LD L,A + LD H,0 + JR DIMF2 +; +BADSUB: LD A,15 + JP ERROR ;"Bad subscript" +; +;VARIABLE-TYPE FUNCTIONS: +; +;Result returned in HLH'L'C (floating point) +;Result returned in HLH'L' (C=0) (integer) +;Result returned in string accumulator & DE (string) +;All registers destroyed. +;IY (text pointer) updated. +;Bit 7 of A indicates type: 0 = numeric, 1 = string. +; +; +;POS - horizontal cursor position. +;VPOS - vertical cursor position. +;EOF - return status of file. +;BGET - read byte from file. +;INKEY - as GET but wait only n centiseconds. +;GET - wait for keypress and return ASCII value. +;GET(n) - input from Z80 port n. +;ASC - ASCII value of string. +;LEN - length of string. +;LOMEM - location of dynamic variables. +;HIMEM - top of available RAM. +;PAGE - start of current text page. +;TOP - address of first free byte after program. +;ERL - line number where last error occurred. +;ERR - number of last error. +;COUNT - number of printing characters since CR. +;Results are integer numeric. +; +TINT: CALL TINTFN + JR COUNT1 +POS: CALL GETCSR + EX DE,HL + JR COUNT1 +VPOS: CALL GETCSR + JR COUNT1 +EOF: CALL CHANEL + CALL OSSTAT + JP Z,TRUE + JP ZERO +BGET: CALL CHANEL ;CHANNEL NUMBER + CALL OSBGET + LD L,A + JR COUNT0 +INKEY: CALL INKEYS + JR ASC0 +GET: CALL NXT + CP '(' + JR NZ,GET0 + CALL ITEMI ;PORT ADDRESS + EXX + LD B,H + LD C,L + IN L,(C) ;INPUT FROM PORT BC + JR COUNT0 +GET0: CALL GETS + JR ASC1 +ASC: CALL ITEMS +ASC0: XOR A + CP E + JP Z,TRUE ;NULL STRING +ASC1: LD HL,(ACCS) + JR COUNT0 +LEN: CALL ITEMS + EX DE,HL + JR COUNT0 +LOMEMV: LD HL,(LOMEM) + JR COUNT1 +HIMEMV: LD HL,(HIMEM) + JR COUNT1 +PAGEV: LD HL,(PAGE) + JR COUNT1 +TOPV: LD A,(IY) + INC IY ;SKIP "P" + CP 'P' + JP NZ,SYNTAX ;"Syntax Error" + CALL GETTOP + JR COUNT1 +ERLV: LD HL,(ERL) + JR COUNT1 +ERRV: LD HL,(ERR) + JR COUNT0 +COUNTV: LD HL,(COUNT) +COUNT0: LD H,0 +COUNT1: EXX + XOR A + LD C,A ;INTEGER MARKER + LD H,A + LD L,A + RET +; +;OPENIN - Open a file for reading. +;OPENOUT - Open a file for writing. +;OPENUP - Open a file for reading or writing. +;Result is integer channel number (0 if error) +; +OPENOT: XOR A + DEFB 21H ;SKIP NEXT 2 BYTES +OPENUP: LD A,2 + DEFB 21H ;SKIP NEXT 2 BYTES +OPENIN: LD A,1 + PUSH AF ;SAVE OPEN TYPE + CALL ITEMS ;FILENAME + LD A,CR + LD (DE),A + POP AF ;RESTORE OPEN TYPE + ADD A,-1 ;AFFECT FLAGS + LD HL,ACCS + CALL OSOPEN + LD L,A + JR COUNT0 +; +;EXT - Return length of file. +;PTR - Return current file pointer. +;Results are integer numeric. +; +EXT: CALL CHANEL + CALL GETEXT + JR TIME0 +; +PTR: CALL CHANEL + CALL GETPTR + JR TIME0 +; +;TIME - Return current value of elapsed time. +;Result is integer numeric. +; +TIMEV: LD A,(IY) + CP '$' + JR Z,TIMEVS + CALL GETIME +TIME0: PUSH DE + EXX + POP HL + XOR A + LD C,A + RET +; +;TIME$ - Return date/time string. +;Result is string +; +TIMEVS: INC IY ;SKIP $ + CALL GETIMS + LD A,80H ;MARK STRING + RET +; +;String comparison: +; +SLT: CALL SCP + RET NC + JR TRUE +; +SGT: CALL SCP + RET Z + RET C + JR TRUE +; +SGE: CALL SCP + RET C + JR TRUE +; +SLE: CALL SCP + JR Z,TRUE + RET NC + JR TRUE +; +SNE: CALL SCP + RET Z + JR TRUE +; +SEQ: CALL SCP + RET NZ +TRUE: LD A,-1 + EXX + LD H,A + LD L,A + EXX + LD H,A + LD L,A + INC A + LD C,A + RET +; +;PI - Return PI (3.141592654) +;Result is floating-point numeric. +; +PI: LD A,35 + JR FPP1 +; +;ABS - Absolute value +;Result is numeric, variable type. +; +ABS: LD A,16 + JR FPPN +; +;NOT - Complement integer. +;Result is integer numeric. +; +CPL: LD A,26 + JR FPPN +; +;DEG - Convert radians to degrees +;Result is floating-point numeric. +; +DEG: LD A,21 + JR FPPN +; +;RAD - Convert degrees to radians +;Result is floating-point numeric. +; +RAD: LD A,27 + JR FPPN +; +;SGN - Return -1, 0 or +1 +;Result is integer numeric. +; +SGN: LD A,28 + JR FPPN +; +;INT - Floor function +;Result is integer numeric. +; +INT: LD A,23 + JR FPPN +; +;SQR - square root +;Result is floating-point numeric. +; +SQR: LD A,30 + JR FPPN +; +;TAN - Tangent function +;Result is floating-point numeric. +; +TAN: LD A,31 + JR FPPN +; +;COS - Cosine function +;Result is floating-point numeric. +; +COS: LD A,20 + JR FPPN +; +;SIN - Sine function +;Result is floating-point numeric. +; +SIN: LD A,29 + JR FPPN +; +;EXP - Exponential function +;Result is floating-point numeric. +; +EXP: LD A,22 + JR FPPN +; +;LN - Natural log. +;Result is floating-point numeric. +; +LN: LD A,24 + JR FPPN +; +;LOG - base-10 logarithm. +;Result is floating-point numeric. +; +LOG: LD A,25 + JR FPPN +; +;ASN - Arc-sine +;Result is floating-point numeric. +; +ASN: LD A,18 + JR FPPN +; +;ATN - arc-tangent +;Result is floating-point numeric. +; +ATN: LD A,19 + JR FPPN +; +;ACS - arc-cosine +;Result is floating point numeric. +; +ACS: LD A,17 +FPPN: PUSH AF + CALL ITEMN + POP AF +FPP1: CALL FPP + JP C,ERROR + XOR A + RET +; +;SFIX - Convert to fixed-point notation +; +SFIX: LD A,38 + JR FPP1 +; +;SFLOAT - Convert to floating-point notation +; +SFLOAT: LD A,39 + JR FPP1 +; +;VAL - Return numeric value of string. +;Result is variable type numeric. +; +VAL: CALL ITEMS +VAL0: XOR A + LD (DE),A + LD IX,ACCS + LD A,36 + JR FPP1 +; +;EVAL - Pass string to expression evaluator. +;Result is variable type (numeric or string). +; +EVAL: CALL ITEMS + LD A,CR + LD (DE),A + PUSH IY + LD DE,ACCS + LD IY,ACCS + LD C,0 + CALL LEXAN2 ;TOKENISE + LD (DE),A + INC DE + XOR A + CALL PUSHS ;PUT ON STACK + LD IY,2 + ADD IY,SP + CALL EXPR + POP IY + ADD IY,SP + LD SP,IY ;ADJUST STACK POINTER + POP IY + EX AF,AF' + RET +; +;RND - Random number function. +; RND gives random integer 0-&FFFFFFFF +; RND(-n) seeds random number & returns -n. +; RND(0) returns last value in RND(1) form. +; RND(1) returns floating-point 0-0.99999999. +; RND(n) returns random integer 1-n. +; +RND: LD IX,RANDOM + CALL NXT + CP '(' + JR Z,RND5 ;ARGUMENT FOLLOWS + CALL LOAD5 +RND1: RR C + LD B,32 +RND2: EXX ;CALCULATE NEXT + ADC HL,HL + EXX + ADC HL,HL + BIT 3,L + JR Z,RND3 + CCF +RND3: DJNZ RND2 +RND4: RL C ;SAVE CARRY + CALL STORE5 ;STORE NEW NUMBER + XOR A + LD C,A + RET +RND5: CALL ITEMI + LD IX,RANDOM + BIT 7,H ;NEGATIVE? + SCF + JR NZ,RND4 ;SEED + CALL TEST + PUSH AF + LD B,C + EX DE,HL + EXX + EX DE,HL + CALL LOAD5 + CALL NZ,RND1 ;NEXT IF NON-ZERO + EXX ;SCRAMBLE (CARE!) + LD C,7FH +RND6: BIT 7,H ;FLOAT + JR NZ,RND7 + EXX + ADD HL,HL + EXX + ADC HL,HL + DEC C + JR NZ,RND6 +RND7: RES 7,H ;POSITIVE 0-0.999999 + POP AF + RET Z ;ZERO ARGUMENT + EXX + LD A,E + DEC A + OR D + EXX + OR E + OR D + RET Z ;ARGUMENT=1 + LD B,0 ;INTEGER MARKER + LD A,10 + CALL FPP ;MULTIPLY + JP C,ERROR + CALL SFIX + JP ADD1 +; +;SUMLEN(array()) +; +SUMLEN: INC IY ;Skip LEN + CALL GETARB + BIT 7,B + JP Z,MISMAT ;Type mismatch + CALL ARRLEN + PUSH HL + POP IX ;IX addresses array + XOR A + LD H,A + LD L,A + LD B,A +SUMLN1: LD C,(IX) + ADD HL,BC + LD C,4 + ADD IX,BC + DEC DE ;Count elements + LD A,D + OR E + JR NZ,SUMLN1 + JP COUNT1 +; +;SUM(array()) +; +SUM: CALL NXT + CP TLEN + JR Z,SUMLEN + CALL GETARB + BIT 7,B + JR NZ,SUMSTR + PUSH BC + CALL ARRLEN + PUSH HL + POP IX ;IX addresses array + CALL ZERO + POP AF ;A = element size +SUMUP: PUSH DE + PUSH AF + CALL DLOADN + LD A,11 + CALL FPP + JP C,ERROR + POP AF + LD D,0 + LD E,A + ADD IX,DE ;Bump to next element + POP DE + DEC DE ;Count elements + LD B,A + LD A,D + OR E + LD A,B + JR NZ,SUMUP + RET +; +;SUM(string array) +; +SUMSTR: CALL ARRLEN + PUSH HL + POP IX ;IX addresses array + EX DE,HL + LD DE,ACCS + LD B,0 +SUMST1: PUSH HL + LD C,(IX) + LD A,C + OR A + JR Z,SUMST2 + ADD A,E + LD A,19 + JP C,ERROR ;"String too long" + LD L,(IX+2) + LD H,(IX+3) + LDIR +SUMST2: POP HL + LD C,4 + ADD IX,BC + DEC HL ;Count elements + LD A,H + OR L + JR NZ,SUMST1 + OR 80H + RET +; +;MOD(array()) +; +MODFUN: CALL GETARB + BIT 7,B + JP NZ,MISMAT + PUSH BC + CALL ARRLEN + PUSH HL + POP IX ;IX addresses array + CALL ZERO + POP AF ;A = element size +MODUP: PUSH DE + PUSH AF + PUSH BC + PUSH HL + EXX + PUSH HL + EXX + CALL LOADN + XOR A + LD B,A + LD D,A + LD E,A + EXX + LD D,A + LD E,2 + EXX + LD A,14 + PUSH IX + CALL FPP ;Square + POP IX + JP C,ERROR + EXX + EX DE,HL + POP HL + EXX + EX DE,HL + POP HL + LD A,C + POP BC + LD B,A + LD A,11 + CALL FPP ;Accumulate + JP C,ERROR + POP AF + LD D,0 + LD E,A + ADD IX,DE ;Bump to next element + POP DE + DEC DE ;Count elements + LD B,A + LD A,D + OR E + LD A,B + JR NZ,MODUP + LD A,30 + CALL FPP ;Square root + XOR A + RET +; +;INSTR - String search. +;Result is integer numeric. +; +INSTR: CALL EXPRS ;STRING TO SEARCH + CALL COMMA + CALL PUSHS ;SAVE STRING ON STACK + CALL EXPRS ;SUB-STRING + POP BC + LD HL,0 + ADD HL,SP ;HL ADDRESSES MAIN + PUSH BC ;C = MAIN STRING LENGTH + LD B,E ;B = SUB-STRING LENGTH + CALL NXT + CP ',' + LD A,0 + JR NZ,INSTR1 + INC IY ;SKIP COMMA + PUSH BC ;SAVE LENGTHS + PUSH HL ;SAVE MAIN ADDRESS + CALL PUSHS + CALL EXPRI + POP BC + CALL POPS + POP HL ;RESTORE MAIN ADDRESS + POP BC ;RESTORE LENGTHS + EXX + LD A,L + EXX + OR A + JR Z,INSTR1 + DEC A +INSTR1: LD DE,ACCS ;DE ADDRESSES SUB + CALL SEARCH + POP DE + JR Z,INSTR2 ;N.B. CARRY CLEARED + SBC HL,HL + ADD HL,SP +INSTR2: SBC HL,SP + EX DE,HL + LD H,0 + ADD HL,SP + LD SP,HL + EX DE,HL + CALL BRAKET + JP COUNT1 +; +;SEARCH - Search string for sub-string +; Inputs: Main string at HL length C +; Sub-string at DE length B +; Starting offset A +; Outputs: NZ - not found +; Z - found at location HL-1 +; Carry always cleared +; +SEARCH: PUSH BC + LD B,0 + LD C,A + ADD HL,BC ;NEW START ADDRESS + POP BC + SUB C + JR NC,SRCH4 + NEG + LD C,A ;REMAINING LENGTH +SRCH1: LD A,(DE) + PUSH BC + LD B,0 + CPIR ;FIND FIRST CHARACTER + LD A,C + POP BC + JR NZ,SRCH4 + LD C,A + DEC B ;Bug fix + CP B ;Bug fix + INC B ;Bug fix + JR C,SRCH4 ;Bug fix + PUSH BC + PUSH DE + PUSH HL + DEC B + JR Z,SRCH3 ;FOUND ! +SRCH2: INC DE + LD A,(DE) + CP (HL) + JR NZ,SRCH3 + INC HL + DJNZ SRCH2 +SRCH3: POP HL + POP DE + POP BC + JR NZ,SRCH1 + XOR A ;Z, NC + RET ;FOUND +; +SRCH4: OR 0FFH ;NZ, NC + RET ;NOT FOUND +; +;CHR$ - Return character with given ASCII value. +;Result is string. +; +CHRS: CALL ITEMI + EXX + LD A,L + JR GET1 +; +;GET$ - Return key pressed as string, or read from file +;Result is string. +; +GETS: CALL NXT + CP '#' + JR Z,GET2 + CALL OSRDCH +GET1: SCF + JR INKEY1 +; +GET2: CALL CHNL ;File channel + CALL NXT + CP TBY + JR Z,GET3 + CP TTO + JR NZ,GET4 +GET3: INC IY + PUSH AF + PUSH DE + CALL ITEMI ;Get BY or TO qualifier + EXX + LD B,H + LD C,L + POP DE + POP AF +GET4: LD HL,ACCS + CP TTO + JR Z,GET5 + LD D,C ;Maximum count + LD BC,100H ;Default + CP TBY + JR Z,GET6 +GET5: LD D,0 + SET 1,B ;Flag no count +GET6: PUSH BC + CALL OSBGET + POP BC + JR C,GET9 ;EOF + BIT 1,B + JR Z,GET8 + CP C + JR Z,GET9 ;NUL (or supplied term) + BIT 7,B + JR NZ,GET7 + BIT 0,B + JR Z,GET8 + CP LF + JR Z,GET9 ;LF +GET7: CP CR + JR Z,GET9 ;CR +GET8: LD (HL),A + INC L + DEC D + JR NZ,GET6 +GET9: EX DE,HL + LD A,80H + RET +; +;INKEY$ - Wait up to n centiseconds for keypress. +; Return key pressed as string or null +; string if time elapsed. +;Result is string. +; +INKEYS: CALL ITEMI + EXX + CALL OSKEY +INKEY1: LD DE,ACCS + LD (DE),A + LD A,80H + RET NC + INC E + RET +; +;MID$ - Return sub-string. +;Result is string. +; +MIDS: CALL EXPRS + CALL COMMA + CALL PUSHS ;SAVE STRING ON STACK + CALL EXPRI + POP BC + CALL POPS + EXX + LD A,L + EXX + OR A + JR Z,MIDS1 + DEC A + LD L,A + SUB E + LD E,0 + JR NC,MIDS1 + NEG + LD C,A + CALL RIGHT1 +MIDS1: CALL NXT + CP ',' + JR Z,LEFT1 + CALL BRAKET + LD A,80H + RET +; +;LEFT$ - Return left part of string. +;Carry cleared if entire string returned. +;Result is string. +; +LEFTS: CALL EXPRS + CALL NXT + CP ',' + JR Z,LEFT1 + CALL BRAKET + LD A,E + OR A + JR Z,LEFT3 + DEC E + JR LEFT3 +; +LEFT1: INC IY + CALL PUSHS ;SAVE STRING ON STACK + CALL EXPRI + POP BC + CALL POPS + CALL BRAKET + EXX + LD A,L + EXX + CP E + JR NC,LEFT3 + LD L,E ;FOR RIGHT$ +LEFT2: LD E,A +LEFT3: LD A,80H ;STRING MARKER + RET +; +;RIGHT$ - Return right part of string. +;Result is string. +; +RIGHTS: CALL EXPRS + CALL NXT + CP ',' + JR Z,RIGHT0 + CALL BRAKET + LD A,E + OR A + JR Z,LEFT3 + DEC A + LD C,1 + JR RIGHT2 +; +RIGHT0: CALL LEFT1 + RET NC + INC E + DEC E + RET Z + LD C,E + LD A,L + SUB E +RIGHT2: LD L,A +RIGHT1: LD B,0 + LD H,D + LD E,B + LDIR ;MOVE + LD A,80H + RET +; +;STRING$ - Return n concatenations of a string. +;Result is string. +; +STRING: CALL EXPRI + CALL COMMA + EXX + LD A,L + EXX + PUSH AF + CALL EXPRS + CALL BRAKET + POP AF + OR A + JR Z,LEFT2 ;N=0 + DEC A + LD C,A + LD A,80H ;STRING MARKER + RET Z + INC E + DEC E + RET Z ;NULL STRING + LD B,E + LD H,D + LD L,0 +STRIN1: PUSH BC +STRIN2: LD A,(HL) + INC HL + LD (DE),A + INC E + LD A,19 + JP Z,ERROR ;"String too long" + DJNZ STRIN2 + POP BC + DEC C + JR NZ,STRIN1 + LD A,80H + RET +; +;SUBROUTINES +; +;TEST - Test HLH'L' for zero +; Outputs: Z-flag set & A=0 if zero +; Destroys: A,F +; +TEST: LD A,H + OR L + EXX + OR H + OR L + EXX + RET +; +;DECODE - Decode line number in pseudo-binary. +; Inputs: IY = Text pointer. +; Outputs: HL=0, H'L'=line number, C=0. +; Destroys: A,C,H,L,H',L',IY,F +; +DECODE: EXX + LD A,(IY) + INC IY + RLA + RLA + LD H,A + AND 0C0H + XOR (IY) + INC IY + LD L,A + LD A,H + RLA + RLA + AND 0C0H + XOR (IY) + INC IY + LD H,A + EXX + XOR A + LD C,A + LD H,A + LD L,A + RET +; +;HEXSTR - convert numeric value to HEX string. +; Inputs: HLH'L'C = integer or floating-point number +; Outputs: String in string accumulator. +; E = string length. D = ACCS/256 +; +HEXSTS: INC IY ;SKIP TILDE + CALL ITEMN + CALL HEXSTR + LD A,80H + RET +; +HEXSTR: CALL SFIX + LD BC,8 + LD DE,ACCS +HEXST1: PUSH BC + LD B,4 + XOR A +HEXST2: EXX + ADD HL,HL + EXX + ADC HL,HL + RLA + DJNZ HEXST2 + POP BC + DEC C + RET M + JR Z,HEXST3 + OR A + JR NZ,HEXST3 + CP B + JR Z,HEXST1 +HEXST3: ADD A,90H + DAA + ADC A,40H + DAA + LD (DE),A + INC DE + LD B,A + JR HEXST1 +; +;Function STR - convert numeric value to ASCII string. +; Inputs: HLH'L'C = integer or floating-point number. +; Outputs: String in string accumulator. +; E = length, D = ACCS/256 +; A = 80H (type=string) +; +;First normalise for decimal output: +; +STRS: CALL NXT + CP '~' + JR Z,HEXSTS + CALL ITEMN + LD IX,STAVAR + LD A,(IX+3) + OR A + LD IX,G9-1 ;G9 FORMAT + JR Z,STR0 +STR: LD IX,STAVAR +STR0: LD DE,ACCS + LD A,37 + CALL FPP + JP C,ERROR + BIT 0,(IX+2) +STR1: LD A,80H ;STRING MARKER + RET Z + LD A,C + ADD A,4 +STR2: CP E + JR Z,STR1 + EX DE,HL + LD (HL),' ' ;TRAILING SPACE + INC HL + EX DE,HL + JR STR2 +; +G9: DEFW 9 +; +;STRING COMPARE +;Compare string (DE) length B with string (HL) length C. +;Result preset to false. +; +SCP: CALL SCP0 +ZERO: LD A,0 + EXX + LD H,A + LD L,A + EXX + LD H,A + LD L,A + LD C,A + RET +; +SCP0: INC B + INC C +SCP1: DEC B + JR Z,SCP2 + DEC C + JR Z,SCP3 + LD A,(DE) + CP (HL) + RET NZ + INC DE + INC HL + JR SCP1 +SCP2: OR A + DEC C + RET Z + SCF + RET +SCP3: OR A + INC C + RET +; +;PUSH$ - SAVE STRING ON STACK. +; Inputs: String in string accumulator. +; E = string length. +; A - saved on stack. +; Destroys: B,C,D,E,H,L,IX,SP,F +; +PUSHS: LD HL,ACCS + CALL CHECK + POP IX ;RETURN ADDRESS + OR A ;CLEAR CARRY + LD D,H + LD C,E + SBC HL,DE + ADD HL,SP + LD SP,HL + LD B,A + PUSH BC + JR Z,PUSHS1 ;ZERO LENGTH + EX DE,HL + LD B,0 + LD L,B ;L=0 + LDIR ;COPY TO STACK + CALL CHECK +PUSHS1: JP (IX) ;"RETURN" +; +;POP$ - RESTORE STRING FROM STACK. +; Inputs: C = string length. +; Outputs: String in string accumulator. +; E = string length. +; Destroys: B,C,D,E,H,L,IX,SP,F +; +POPS: POP IX ;RETURN ADDRESS + LD HL,0 + LD B,H ;B=0 + ADD HL,SP + LD DE,ACCS + INC C + DEC C + JR Z,POPS1 ;ZERO LENGTH + LDIR ;COPY FROM STACK +POPS1: LD SP,HL + JP (IX) ;"RETURN" +; +BINDIG: LD A,(IY) + CP '0' + RET C + CP '1'+1 + CCF + RET C + SUB '0' + RET +; +HEXDIG: LD A,(IY) + CP '0' + RET C + CP '9'+1 + CCF + RET NC + CP 'A' + RET C + SUB 'A'-10 + CP 16 + CCF + RET +; +RELOPQ: CP '>' + RET NC + CP '=' + RET NC + CP '<' + RET +; +COMMA: CALL NXT + INC IY + CP ',' + RET Z + LD A,5 + JR ERROR1 ;"Missing ," +; +BRAKET: CALL NXT + INC IY + CP ')' + RET Z + LD A,27 +ERROR1: JP ERROR ;"Missing )" +; +SAVE: INC IY + AND 0FH +SAVE1: EX AF,AF' + JP M,MISMAT + EX AF,AF' + EX (SP),HL + EXX + PUSH HL + EXX + PUSH AF + PUSH BC + JP (HL) +; +DOIT: EX AF,AF' + JP M,MISMAT + EXX + POP BC ;RETURN ADDRESS + EXX + LD A,C + POP BC + LD B,A + POP AF ;OPERATOR + EXX + EX DE,HL + POP HL + EXX + EX DE,HL + POP HL + EXX + PUSH BC + EXX + CALL FPP + JR C,ERROR1 + XOR A + EX AF,AF' ;TYPE + LD A,(IY) + RET +; +DISPT2: PUSH HL + LD HL,SOPTBL + JR DISPT0 +; +DISPAT: PUSH HL + SUB FUNTOK + LD HL,FUNTBL +DISPT0: PUSH BC + ADD A,A + LD C,A + LD B,0 + ADD HL,BC + LD A,(HL) + INC HL + LD H,(HL) + LD L,A + POP BC + EX (SP),HL + RET ;OFF TO ROUTINE +; +STOREA: LD A,D + PUSH DE + PUSH HL + EX (SP),IX + OR A + JP M,STORA1 + CALL LOADN + EX (SP),IX + CALL MODIFY + POP HL + POP DE + LD C,D + LD B,0 + RET +; +STORA1: PUSH DE + CALL LOADS + POP HL + EX (SP),IX + CALL MODIFS + POP HL + POP DE + LD BC,4 + RET +; +; Assign to whole array: +; array1() = array expression +; array1() = n1,n2,n3,n4... +; array1() = n (n copied into all elements) +; +; Inputs: D = type (65, 68, 69, 193) +; E = opcode ('=' for store, '+','-' etc. for modify) +; HL = IX = VARPTR +; IY = text pointer +; +LETARR: RES 6,D ;Lose array marker + PUSH DE ;Save type & opcode + CALL GETAR1 ;Get and check indirect link + CALL ARRLEN ;DE = elements, HL addresses first + POP BC + LD A,B ;A = type + PUSH DE + PUSH BC + PUSH HL + CALL X14OR5 ;DE = size in bytes + LD B,D + LD C,E + POP IX + POP DE +; +; (SP) = number of elements +; BC = size in bytes +; DE = type & opcode +; IX = address of first element +; +; allocate space on stack and zero it: +; + XOR A ;Clear carry and zero error code + LD HL,0 + ADD HL,SP ;HL = SP + SBC HL,BC + JP C,ERROR ;'No room' + PUSH BC + LD BC,(FREE) + INC B ;Safety margin + SBC HL,BC + ADD HL,BC + POP BC + JP C,ERROR ;'No room' + LD SP,HL +LETA0: LD (HL),0 + INC HL + DEC BC + LD A,B + OR C + JR NZ,LETA0 ;Clear allocated stack + LD C,(HL) + INC HL + LD B,(HL) + LD H,A + LD L,A + ADD HL,SP +; +; CALL NXT +; CP TEVAL ;;EVAL not currently supported +; + CALL EXPRA + LD SP,HL ;Update stack pointer + POP BC ;Level stack + JP XEQ +; +; EXPRA - Evaluate array expression, strictly left-to-right; +; Note: String array arithmetic (concatenation) is not supported +; because it would require a way of recovering freed string space. +; +; Inputs: BC = number of elements +; DE = type & opcode +; HL = address of temporary stack space +; IX = address of first element of array +; Outputs: HL = value to set stack pointer to +; +EXPRA: LD A,'=' + DEC IY +EXPRA1: INC IY + PUSH DE + PUSH BC + PUSH HL + PUSH IX + LD E,A ;For unary minus + CALL NXT + CALL ITEMA + POP IX + POP HL + POP BC + POP DE + CALL NXT + CP ',' ;List? + JR Z,EXPRA3 + CALL TERMQ + JR NZ,EXPRA1 +; +; Update destination array from stack: +; +EXPRA2: PUSH BC + CALL STOREA ;(IX) <- (HL) + ADD HL,BC + ADD IX,BC + POP BC + DEC BC + LD A,B + OR C + JR NZ,EXPRA2 + RET +; +; Update destination array from list (n.b. not transferred via stack): +; +EXPRA3: PUSH BC + CALL STOREA ;(IX) <- (HL) +EXPRA4: INC IY ;Bump past comma + ADD HL,BC + ADD IX,BC + POP BC + DEC BC + LD A,B + OR C + RET Z + PUSH BC + PUSH DE + PUSH HL + PUSH IX + BIT 7,D + JR NZ,EXPRA5 + PUSH DE + CALL EXPRN + POP DE + POP IX + PUSH IX + CALL MODIFY + JR EXPRA6 +; +EXPRA5: PUSH DE + CALL EXPRS + POP HL + POP IX + PUSH IX + CALL MODIFS +EXPRA6: POP IX + POP HL + POP DE + LD BC,4 + BIT 7,D + JR NZ,EXPRA7 + LD C,D +EXPRA7: CALL NXT + CP ',' + JR Z,EXPRA4 + POP DE +EXPRA8: ADD HL,BC ;Skip remaining elements + DEC DE + LD A,D + OR E + JR NZ,EXPRA8 + RET +; +; ITEMA: evaluate and operate on array item +; Inputs: A = operator +; D = type +; E = operator +; BC = number of elements +; HL = pointer to destination on stack +; IY = text pointer +; Outputs: IY updated +; Destroys: Everything except SP +; +ITEMA: CP '-' + JR NZ,ITEMA1 ;Not unary minus + LD A,E + CP '=' + JR NZ,ITEMA1 ;Not unary minus + INC IY ;Bump past '-' + CALL NXT + LD E,'-' ;Unary minus +ITEMA1: PUSH HL ;Pointer to destination + PUSH BC ;Number of elements + PUSH DE ;Type and previous operator + PUSH IY ;In case normal expression + CALL GETVAR + JR NZ,ITEMA4 ;Non-array expression + BIT 6,A + JR Z,ITEMA4 ;Not a whole array + POP BC ;Junk saved text pointer + POP DE ;Type & operator + RES 6,A + CP D + JP NZ,MISMAT ;'Type mismatch' + PUSH DE ;Save type & operator again + CALL GETAR1 + CALL ARRLEN + LD B,D ;BC = number of elements + LD C,E + POP DE ;Restore type & operator + EX (SP),HL + CALL NXT + POP IX ;Pointer to source + CP '.' + JP Z,ARRDOT ;Dot product + OR A + SBC HL,BC ;Same number of elements? + JP NZ,MISMAT ;'Type mismatch' + POP HL ;Pointer to destination + BIT 7,D + JR NZ,ITEMA3 +; +; Process numeric array item: +; +ITEMA2: PUSH BC + PUSH HL + LD A,D + CALL LOADN + EX (SP),IX + PUSH DE + CALL MODIFY + POP DE + EX (SP),IX + POP HL + LD C,D + LD B,0 + ADD IX,BC + ADD HL,BC + POP BC + DEC BC + LD A,B + OR C + JR NZ,ITEMA2 + RET +; +; Process string array item (just copy descriptors): +; +ITEMA3: EX DE,HL ;DE = destination + LD H,B + LD L,C + ADD HL,HL + ADD HL,HL + LD B,H + LD C,L + PUSH IX + POP HL ;HL = source + LDIR + RET +; +; Process numeric non-array item: +; +ITEMA4: POP IY ;Restore text pointer + BIT 7,D + JR NZ,ITEMA5 + CALL EXPR4 ;; should be EXP345 + LD A,C ;Exponent + POP DE ;Type / operator + POP BC ;Count + POP IX +ITEMA7: PUSH HL + PUSH BC + PUSH DE + EXX + PUSH HL + EXX + PUSH AF + LD C,A + CALL MODIFY + POP AF + EXX + POP HL + EXX + POP DE + LD C,D + LD B,0 + ADD IX,BC + POP BC + DEC BC + SBC HL,HL + SBC HL,BC + POP HL + JR NZ,ITEMA7 ;Copy into every element! + RET +; +; Process string non-array item: +; +ITEMA5: CALL EXPRS + LD A,E + OR A + JR Z,ITEMA0 + LD HL,ACCS + LD DE,BUFFER + LD C,A + LD B,0 + LDIR +ITEMA0: POP DE + POP BC + POP IX + EXX + LD L,A + EXX + LD DE,4 + LD HL,BUFFER +ITEMA6: CALL STORE4 + ADD IX,DE + DEC BC + LD A,B + OR C + JR NZ,ITEMA6 ;Copy into every element! + RET +; +; Array dot-product: +; +ARRDOT: INC IY ;Bump past dot + LD A,D ;Type + OR A + JP M,MISMAT ;'Type mismatch' + EX DE,HL + POP HL +; +; A = type +; DE = no. of elements in destination array (outer loop counter) +; IX = pointer to first source array data +; HL = pointer to destination data +; IY = text pointer +; + PUSH DE + PUSH HL + PUSH IX + PUSH AF + CALL GETARR + CALL ARRLEN + POP AF + EX DE,HL + LD L,(IX) + LD H,(IX+1) ;Indirect pointer + LD L,(HL) ;No. of dimensions + DEC L + EX DE,HL + POP IX + POP BC + POP DE +; + PUSH IY ;Save text pointer + PUSH BC ;Save destination pointer + PUSH HL + POP IY +; +; Get row counts: +; + LD HL,1 + JR Z,ARR1D + LD H,(IY-1) + LD L,(IY-2) +ARR1D: PUSH AF + PUSH DE + LD C,A + LD B,0 + CALL MUL16 + POP DE + POP AF + LD B,(IX-1) + LD C,(IX-2) +; +; A = type, Z-flag set if first array is one-dimensional +; BC = no. of rows of first source array (inner loop counter) +; DE = no. of elements in destination array (outer loop counter) +; HL = no. of rows of second source array * size of each element +; IX = pointer to first source array +; IY = pointer to second source array +; (SP) = pointer to destination data +; +; Dot-product outer loop: +; +OUTER: PUSH BC ;1 + PUSH DE ;2 + PUSH HL ;3 + PUSH IX ;4 + PUSH IY ;5 + LD D,B + LD E,C + PUSH AF + CALL ZERO ;Zero accumulator + POP AF +INNER: PUSH DE ;6 + PUSH BC ;Save accumulator + PUSH HL + EXX + PUSH HL + EXX +; + CALL LOADN ;Load from (IX) + PUSH IX + EX (SP),IY + POP IX +; + CALL DLOADN ;Load from (IY) + PUSH IX + EX (SP),IY + POP IX +; + PUSH AF + LD A,10 + CALL FPP ;Multiply + JP C,ERROR + POP AF +; + EXX ;Restore accumulator + EX DE,HL + POP HL + EXX + EX DE,HL + POP HL + EX AF,AF' + LD A,C + POP BC + LD B,A + EX AF,AF' +; + PUSH AF + LD A,11 + CALL FPP ;Accumulate + JP C,ERROR + POP AF +; +; Bump pointers: +; + POP DE ;5 +; + EXX + LD C,A + LD B,0 + ADD IX,BC + POP DE + POP BC + EX (SP),HL + EX DE,HL + ADD IY,DE + EX DE,HL + EX (SP),HL + PUSH BC + PUSH DE + EXX +; +; Count inner loops: +; + DEC DE ;Inner loop counter + INC E + DEC E + JR NZ,INNER + INC D + DEC D + JR NZ,INNER +; + POP IY ;4 + POP IX ;3 +; +; Swap pointers: +; + EXX + EX AF,AF' + POP AF + POP BC + POP DE + EX (SP),IX + PUSH DE + PUSH BC + PUSH AF + EX AF,AF' + EXX +; +; Save to destination array and bump pointer: +; + PUSH AF + PUSH DE + CALL STOREN + POP DE + POP AF + LD C,A + LD B,0 + ADD IX,BC +; +; Swap pointers: +; + EXX + EX AF,AF' + POP AF + POP BC + POP DE + EX (SP),IX + PUSH DE + PUSH BC + PUSH AF + EX AF,AF' + EXX +; + POP HL ;2 + POP DE ;1 Outer loop counter + POP BC ;0 + DEC DE ;Count outer loops +; +; Adjust IX & IY +; + PUSH BC + PUSH DE + PUSH HL + LD C,A + LD B,0 + ADD IY,BC + PUSH AF + PUSH HL + EX DE,HL + CALL MUL16 + EX DE,HL + POP BC + CALL MOD16 + POP AF + OR A + LD BC,0 + SBC HL,BC + POP HL + POP DE + POP BC + JR NZ,MODNZ + PUSH DE + PUSH HL + EX DE,HL + PUSH IY + POP HL + OR A + SBC HL,DE + PUSH HL + POP IY + LD L,A + LD H,0 + PUSH AF + CALL MUL16 + POP AF + EX DE,HL + ADD IX,DE + POP HL + POP DE +MODNZ: +; +; Count outer loops: +; + INC E + DEC E + JP NZ,OUTER + INC D + DEC D + JP NZ,OUTER +; +; Exit: +; + POP HL + POP IY + RET +; +; HL = DE MOD BC +; +MOD16: XOR A + LD H,A + LD L,A + LD A,17 +MOD160: SBC HL,BC + JR NC,MOD161 + ADD HL,BC +MOD161: CCF + RL E + RL D + DEC A + RET Z + ADC HL,HL + JR MOD160 +; + END diff --git a/src/EXEC.Z80 b/src/EXEC.Z80 new file mode 100644 index 0000000..b2db858 --- /dev/null +++ b/src/EXEC.Z80 @@ -0,0 +1,3273 @@ + TITLE BBC BASIC (C) R.T.RUSSELL 1981-2024 +; +;BBC BASIC INTERPRETER - Z80 VERSION +;STATEMENT EXECUTION MODULE - "EXEC" +;(C) COPYRIGHT R.T.RUSSELL 1981-2024 +; +;THE NAME BBC BASIC IS USED WITH THE PERMISSION +;OF THE BRITISH BROADCASTING CORPORATION AND IS +;NOT TRANSFERRABLE TO A FORKED OR DERIVED WORK. +; +;VERSION 2.1, 22-01-1984 +;VERSION 3.1, 11-06-1987 +;VERSION 5.0, 19-05-2024 +; + GLOBAL XEQ + GLOBAL RUN0 + GLOBAL CHAIN0 + GLOBAL CHECK + GLOBAL MUL16 + GLOBAL X14OR5 + GLOBAL TERMQ + GLOBAL STOREN + GLOBAL STORE4 + GLOBAL STORE5 + GLOBAL STACCS + GLOBAL SPACES + GLOBAL FN + GLOBAL USR + GLOBAL ESCAPE + GLOBAL SYNTAX + GLOBAL CHANEL + GLOBAL CHNL + GLOBAL VAR + GLOBAL TABIT + GLOBAL MODIFY + GLOBAL MODIFS +; + EXTRN ASSEM + EXTRN ERROR + EXTRN REPORT + EXTRN WARM + EXTRN CLOOP + EXTRN SAYLN + EXTRN LOAD0 + EXTRN CRLF + EXTRN PBCDL + EXTRN TELL + EXTRN FINDL + EXTRN SETLIN + EXTRN CLEAR + EXTRN GETVAR + EXTRN PUTVAR + EXTRN GETDEF + EXTRN LOCATE + EXTRN CREATE + EXTRN OUTCHR + EXTRN EXTERR + EXTRN BYE + EXTRN NXT + EXTRN NLIST +; + EXTRN OSWRCH + EXTRN OSLINE + EXTRN OSSHUT + EXTRN OSBPUT + EXTRN OSBGET + EXTRN CLRSCN + EXTRN PUTCSR + EXTRN PUTIME + EXTRN PUTIMS + EXTRN PUTPTR + EXTRN OSCALL + EXTRN OSCLI + EXTRN TRAP +; + EXTRN SOUND + EXTRN CLG + EXTRN DRAW + EXTRN ENVEL + EXTRN GCOL + EXTRN MODE + EXTRN MOVE + EXTRN PLOT + EXTRN COLOUR + EXTRN CIRCLE + EXTRN ELLIPSE + EXTRN FILL + EXTRN MOUSE + EXTRN ORIGIN + EXTRN RECTAN + EXTRN LINE + EXTRN WAIT + EXTRN TINT + EXTRN SYS +; + EXTRN STR + EXTRN HEXSTR + EXTRN EXPR + EXTRN EXPRN + EXTRN EXPRI + EXTRN EXPRS + EXTRN ITEMI + EXTRN CONS + EXTRN LOADS + EXTRN VAL0 + EXTRN SFIX + EXTRN TEST + EXTRN LOAD4 + EXTRN LOADN + EXTRN DLOAD5 + EXTRN FPP + EXTRN COMMA + EXTRN BRAKET + EXTRN PUSHS + EXTRN POPS + EXTRN ZERO + EXTRN SCP + EXTRN LETARR +; + EXTRN ACCS + EXTRN PAGE + EXTRN LOMEM + EXTRN HIMEM + EXTRN FREE + EXTRN BUFFER + EXTRN ERRTRP + EXTRN ONERSP + EXTRN CURLIN + EXTRN COUNT + EXTRN WIDTH + EXTRN STAVAR + EXTRN DATPTR + EXTRN RANDOM + EXTRN TRACEN + EXTRN LISTON + EXTRN PC + EXTRN OC +; +LF EQU 0AH +CR EQU 0DH +TAND EQU 80H +TOR EQU 84H +TERROR EQU 85H +TLINE EQU 86H +TOFF EQU 87H +TSTEP EQU 88H +TSPC EQU 89H +TTAB EQU 8AH +TELSE EQU 8BH +TTHEN EQU 8CH +TLINO EQU 8DH +TTO EQU 0B8H +TCMD EQU 0C0H +TWHILE EQU 0C7H +TWHEN EQU 0C9H +TOF EQU 0CAH +TENDCASE EQU 0CBH +TOTHERWISE EQU 0CCH +TENDIF EQU 0CDH +TENDWHILE EQU 0CEH +TCALL EQU 0D6H +TDATA EQU 0DCH +TDEF EQU 0DDH +TFOR EQU 0E3H +TGOSUB EQU 0E4H +TGOTO EQU 0E5H +TLOCAL EQU 0EAH +TNEXT EQU 0EDH +TON EQU 0EEH +TPROC EQU 0F2H +TREM EQU 0F4H +TREPEAT EQU 0F5H +TRETURN EQU 0F8H +TSTOP EQU 0FAH +TUNTIL EQU 0FDH +TEXIT EQU 10H +; +CMDTAB: DEFW LEFTSL + DEFW MIDSL + DEFW RITESL + DEFW SYNTAX ;STR$ + DEFW SYNTAX ;STRING$ + DEFW SYNTAX ;EOF + DEFW SYNTAX ;SUM + DEFW WHILE + DEFW CASE + DEFW SYNTAX ;WHEN + DEFW SYNTAX ;OF + DEFW XEQ ;ENDCASE + DEFW SYNTAX ;OTHERWISE + DEFW XEQ ;ENDIF + DEFW ENDWHI ;ENDWHILE + DEFW PTR + DEFW PAGEV + DEFW TIMEV + DEFW LOMEMV + DEFW HIMEMV + DEFW SOUND + DEFW BPUT + DEFW CALL + DEFW CHAIN + DEFW CLR + DEFW CLOSE + DEFW CLG + DEFW CLS + DEFW REM ;DATA + DEFW REM ;DEF + DEFW DIM + DEFW DRAW + DEFW END + DEFW ENDPRO + DEFW ENVEL + DEFW FOR + DEFW GOSUB + DEFW GOTO + DEFW GCOL + DEFW IF + DEFW INPUT + DEFW LET + DEFW LOCAL + DEFW MODE + DEFW MOVE + DEFW NEXT + DEFW ON + DEFW VDU + DEFW PLOT + DEFW PRINT + DEFW PROC + DEFW READ + DEFW REM + DEFW REPEAT + DEFW REPOR + DEFW RESTOR + DEFW RETURN + DEFW RUN + DEFW STOP + DEFW COLOUR + DEFW TRACE + DEFW UNTIL + DEFW WIDTHV + DEFW CLI ;OSCLI + DEFW REM ;NUL + DEFW CIRCLE + DEFW ELLIPSE + DEFW FILL + DEFW MOUSE + DEFW ORIGIN + DEFW BYE ;QUIT + DEFW RECTAN + DEFW SWAP + DEFW SYS + DEFW TINT + DEFW WAIT + DEFW SYNTAX ;INSTALL + DEFW REM ;CR + DEFW PUT ;Token changed + DEFW SYNTAX ;BY + DEFW EXIT +; +TLAST EQU TCMD-128+($-CMDTAB)/2 +; +RUN: CALL TERMQ + JR Z,RUN0 +CHAIN: CALL EXPRS + LD A,CR + LD (DE),A +CHAIN0: LD SP,(HIMEM) + CALL LOAD0 +RUN0: LD SP,(HIMEM) ;PREPARE FOR RUN + LD IX,RANDOM +RAND: LD A,R ;RANDOMISE (CARE!) + JR Z,RAND + RLCA + RLCA + LD (IX+3),A + SBC A,A + LD (IX+4),A + CALL CLEAR + LD HL,0 + LD (ERRTRP),HL + LD HL,(PAGE) + CALL DSRCH ;LOOK FOR "DATA" + LD (DATPTR),HL ;SET DATA POINTER + LD IY,(PAGE) +XEQ0: CALL NEWLIN + LD A,(IY) + CP TELSE + JP Z,MELSE ;ELSE + CP TWHEN + JP Z,WHEN ;WHEN + CP TOTHERWISE + JP Z,WHEN +XEQ: LD (CURLIN),IY ;ERROR POINTER + CALL TRAP ;CHECK KEYBOARD +XEQ1: CALL NXT + INC IY + CP ':' ;SEPARATOR + JR Z,XEQ1 + CP CR + JR Z,XEQ0 ;NEW PROGRAM LINE + CP TLAST + JP PE,LET0 ;IMPLIED LET + SUB TCMD + JP M,EXTRAS + ADD A,A + LD C,A + LD B,0 + LD HL,CMDTAB + ADD HL,BC + LD A,(HL) ;TABLE ENTRY + INC HL + LD H,(HL) + LD L,A + CALL NXT + JP (HL) ;EXECUTE STATEMENT +; +;END +; +ENDIM: PUSH IY + POP HL + LD BC,(PAGE) + SBC HL,BC ;IMMEDIATE MODE ? + JP C,CLOOP +END: LD E,0 + CALL OSSHUT ;CLOSE ALL FILES + JP WARM ;"Ready" +; +NEWLIN: LD A,(IY+0) ;A=LINE LENGTH + LD BC,3 + ADD IY,BC + OR A + JR Z,ENDIM ;LENGTH=0, EXIT + LD HL,(TRACEN) + LD A,H + OR L + RET Z + LD D,(IY-1) ;DE = LINE NUMBER + LD E,(IY-2) + SBC HL,DE + RET C + EX DE,HL + LD A,'[' ;TRACE + CALL OUTCHR + CALL PBCDL + LD A,']' + CALL OUTCHR + LD A,' ' + JP OUTCHR +; +;ROUTINES FOR EACH STATEMENT: +; +;OSCLI +; +CLI: CALL EXPRS + LD A,CR + LD (DE),A + LD HL,ACCS + CALL OSCLI + JR XEQ +; +;REM, * +; +EXT: PUSH IY + POP HL + CALL OSCLI +REM: PUSH IY + POP HL + LD A,CR + LD B,A + CPIR ;FIND LINE END + PUSH HL + POP IY + JP XEQ0 +; +EXTRAS: CP TELSE-TCMD + JR Z,REM ;ELSE + CP TERROR-TCMD + JR Z,THROW ;ERROR + CP TLINE-TCMD + JP Z,LINE ;LINE + JP SYNTAX +; +;ERROR num,string$ +; +THROW: CALL EXPRI + EXX + PUSH HL + EXX + CALL COMMA + CALL EXPRS + POP HL + XOR A + LD (DE),A + LD A,L + LD HL,ACCS + LD DE,BUFFER + PUSH DE + LD BC,256 + LDIR + JP EXTERR +; +; SWAP +; +SWAP: CALL GETVAR + JR NZ,SWAPNZ + PUSH AF + PUSH HL + CALL COMMA + CALL NXT + CALL GETVAR +SWAPNZ: JR NZ,NOSUCH + POP DE + POP BC + CP B + JR NZ,MISMAT + AND 00001111B + JR Z,MISMAT + LD A,B + AND 11000000B + JR Z,SWAP1 + LD B,2 + JP P,SWAP1 + JP PE,SWAP1 + LD B,4 +SWAP1: LD C,(HL) + LD A,(DE) + LD (HL),A + LD A,C + LD (DE),A + INC DE + INC HL + DJNZ SWAP1 + JR XEQR +; +;[LET] var = expr +; +LET0: CP '*' + JR Z,EXT + CP '=' + JR Z,FNEND + CP '[' + JR Z,ASM + DEC IY +LET: CALL ASSIGN + JP Z,XEQ + JR C,SYNTAX ;"Syntax error" + JP P,LETARR ;Numeric array + JP PE,LETARR ;String array + LD A,D ;Type + PUSH DE + PUSH HL + CALL EXPRS + POP IX + POP HL + CALL MODIFS +XEQR: JP XEQ +; +; GETSTR - Get string variable +; Inputs: IY = text pointer +; Outputs: B = type +; Z-flag set if comma +; +GETSTR: CALL GETVAR + JR NZ,NOSUCH + LD B,A + AND 11000000B + JP P,MISMAT + JP PE,BADUSE + BIT 0,B + JR Z,MISMAT + CALL NXT + CP ',' + RET +; +VAR: CALL GETVAR + RET Z + JP NC,PUTVAR +NOSUCH: LD A,26 ;'No such variable' + DEFB 21H +SYNTAX: LD A,16 ;"Syntax error" + DEFB 21H +ESCAPE: LD A,17 ;"Escape" + DEFB 21H +BADUSE: LD A,14 ;'Bad use of array' + DEFB 21H +MISMAT: LD A,6 ;'Type mismatch' +ERROR0: JP ERROR +; +ASM0: CALL NEWLIN +ASM: LD (CURLIN),IY + CALL TRAP + CALL ASSEM + JR C,SYNTAX + CP CR + JR Z,ASM0 + LD HL,LISTON + LD A,(HL) + AND 0FH + OR 30H + LD (HL),A + JR XEQR +; +;= +; +FNEND: CALL EXPR ;FUNCTION RESULT + EX AF,AF' + ADD A,A + LD A,E + JR C,FNEND1 + LD A,C +FNEND1: EX AF,AF' + PUSH HL + EXX + POP BC + EX DE,HL ;SAVE RESULT IN A'B'C'D'E' + EXX +FNEND2: POP BC + LD HL,FNCHK + XOR A + SBC HL,BC + JR Z,FNEND3 + PUSH BC + CALL RESLOC + JR NZ,FNEND2 + LD A,7 + JR ERROR0 ;"No FN" +; +FNEND3: POP IY + LD (CURLIN),IY ;IN CASE OF ERROR + EXX + EX DE,HL + PUSH BC + EXX + POP HL + EX AF,AF' + LD E,A + LD C,A + RRA + RET +; +;DIM var(dim1[,dim2[,...]])[,var(...] +;DIM var expr[,var expr...] +; +DIM: PUSH IY + CP '!' + JP Z,DIM4 + CALL LOCATE ;VARIABLE + JP C,BADDIM + CALL NZ,CREATE + LD A,(IY) + CP '(' + JP NZ,DIM4 + PUSH HL + POP IX + LD A,(HL) + AND 0FEH + INC HL + OR (HL) + JP NZ,DIM4 + POP BC ;LEVEL STACK + LD A,D + LD HL,(FREE) + PUSH HL + EX (SP),IX + PUSH HL + PUSH AF ;SAVE TYPE + LD DE,1 + LD B,D ;DIMENSION COUNTER +DIM1: INC IY + PUSH BC + PUSH DE + PUSH IX + CALL EXPRI ;DIMENSION SIZE + BIT 7,H + JR NZ,BADDIM + EXX + INC HL + POP IX + INC IX + LD (IX),L ;SAVE SIZE + INC IX + LD (IX),H + POP BC + CALL MUL16 ;HL=HL*BC + JR C,NOROOM ;TOO LARGE + EX DE,HL ;DE=PRODUCT + POP BC + INC B ;DIMENSION COUNTER + LD A,(IY) + CP ',' ;ANOTHER + JR Z,DIM1 + INC IX + CALL BRAKET ;CLOSING BRACKET + POP AF ;RESTORE TYPE + CALL X14OR5 ;DE=DE*n + JR C,NOROOM + POP HL + LD (HL),B ;NO. OF DIMENSIONS + EX (SP),IX + POP HL + AND 80H + OR (IX) ;FLAGS +; +; A = flags: bit 7 = string, bit 0 = LOCAL +; DE = amount to allocate +; HL = where to allocate (if not LOCAL) +; (HL - FREE is size of 'descriptor') +; IX = where to store pointer +; +DIM3: PUSH HL + INC H ;Safety margin + ADD HL,DE + JR C,NOROOM + SBC HL,SP + JR NC,NOROOM + POP HL + PUSH HL + LD BC,(FREE) + OR A + SBC HL,BC + LD B,H + LD C,L + POP HL + SBC HL,BC + BIT 0,A + JR Z,ARRCHK ;NOT LOCAL + LD HL,0 + ADD HL,SP + SBC HL,DE + SBC HL,BC + LD SP,HL + PUSH DE + PUSH BC + PUSH AF + CALL ARRCHK +ARRCHK: LD (IX+0),L ;SAVE POINTER + LD (IX+1),H + LD A,B + OR C + JR Z,DIM2 + PUSH DE + EX DE,HL + LD HL,(FREE) + LDIR ;COPY DESCRIPTOR + EX DE,HL + POP DE +DIM2: LD A,D + OR E + JR Z,DIM5 + LD (HL),0 ;INITIALISE ARRAY + INC HL + DEC DE + JR DIM2 +; +BADDIM: LD A,10 ;"Bad DIM" + DEFB 21H +NOROOM: LD A,11 ;"DIM space" +ERROR1: JP ERROR +; +DIM5: SBC HL,SP + JR NC,DIM7 ;LOCAL + ADD HL,SP + LD (FREE),HL +DIM7: CALL NLIST ;ANOTHER VARIABLE? + JP DIM +; +DIM4: POP IY + CALL VAR + OR A + JR Z,BADDIM + JP M,BADDIM + BIT 6,A + JR NZ,BADDIM + LD B,A ;TYPE + CALL NXT + CP TLOCAL + LD A,0 ;PRESET TO NOT LOCAL + JR NZ,DIM8 + INC IY + INC A ;FLAG LOCAL +DIM8: PUSH AF + LD A,B ;TYPE + EXX + LD HL,0 + LD C,H + CALL STOREN ;RESERVED AREA + PUSH IX + CALL EXPRI + POP IX + EXX + INC HL + EX DE,HL + LD HL,(FREE) + POP AF ;LOCAL FLAG + JP DIM3 +; +;PRINT list... +;PRINT #channel,list... +; +PRINT: CP '#' + JR NZ,PRINT0 + CALL CHNL ;CHANNEL NO. = E +PRNTN1: CALL NLIST + PUSH DE + CALL EXPR ;ITEM TO PRINT + EX AF,AF' + JP M,PRNTN2 ;STRING + POP DE + PUSH BC + EXX + LD A,L + EXX + CALL OSBPUT + EXX + LD A,H + EXX + CALL OSBPUT + LD A,L + CALL OSBPUT + LD A,H + CALL OSBPUT + POP BC + LD A,C + CALL OSBPUT + JR PRNTN1 +PRNTN2: LD C,E + POP DE + LD HL,ACCS + INC C +PRNTN3: DEC C + JR Z,PRNTN4 + LD A,(HL) + INC HL + PUSH BC + CALL OSBPUT + POP BC + JR PRNTN3 +PRNTN4: LD A,CR + CALL OSBPUT + JR PRNTN1 +; +PRINT6: LD B,2 + JR PRINTC +PRINT8: LD BC,100H + JR PRINTC +PRINT9: LD HL,STAVAR + XOR A + CP (HL) + JR Z,PRINT0 + LD A,(COUNT) + OR A + JR Z,PRINT0 +PRINTA: SUB (HL) + JR Z,PRINT0 + JR NC,PRINTA + NEG + CALL SPACES +PRINT0: LD A,(STAVAR) + LD C,A ;PRINTS + LD B,0 ;PRINTF +PRINTC: CALL TERMQ + JR Z,PRINT4 + RES 0,B + INC IY + CP '~' + JR Z,PRINT6 + CP ';' + JR Z,PRINT8 + CP ',' + JR Z,PRINT9 + CALL FORMAT ;SPC, TAB, ' + JR Z,PRINTC + DEC IY + PUSH BC + CALL EXPR ;VARIABLE TYPE + EX AF,AF' + JP M,PRINT3 ;STRING + POP DE + PUSH DE + BIT 1,D + PUSH AF + CALL Z,STR ;DECIMAL + POP AF + CALL NZ,HEXSTR ;HEX + POP BC + PUSH BC + LD A,C + SUB E + CALL NC,SPACES ;RIGHT JUSTIFY +PRINT3: POP BC + CALL PTEXT ;PRINT + JR PRINTC +PRINT4: BIT 0,B + CALL Z,CRLF + JR XEQGO3 +; +ONERR: INC IY ;SKIP "ERROR" + CALL NXT + LD HL,0 ;FLAG NOT LOCAL + CP TLOCAL + JR NZ,ONERR1 + INC IY ;SKIP "LOCAL" + LD HL,(ERRTRP) + PUSH HL + LD HL,(ONERSP) + PUSH HL + LD HL,400H ;TYPE = 4, 'EXPONENT' = 0 + PUSH HL + LD HL,ERRTRP + PUSH HL + LD HL,LOCCHK + PUSH HL + LD HL,0 + ADD HL,SP + CALL NXT +ONERR1: LD (ONERSP),HL + LD (ERRTRP),IY + CP TOFF + JP NZ,REM + INC IY ;SKIP "OFF" + SBC HL,HL + LD (ONERSP),HL + LD (ERRTRP),HL +XEQGO3: JP XEQ +; +;ON expr GOTO line[,line...] [ELSE statement] +;ON expr GOTO line[,line...] [ELSE line] +;ON expr GOSUB line[,line...] [ELSE statement] +;ON expr GOSUB line[,line...] [ELSE line] +;ON expr PROCone [,PROCtwo..] [ELSE PROCotherwise] +;ON ERROR [LOCAL] statement [:statement...] +;ON ERROR [LOCAL] OFF +; +ON: CP TERROR + JR Z,ONERR ;"ON ERROR" + CALL EXPRI + LD A,(IY) + INC IY + LD E,',' ;SEPARATOR + CP TGOTO + JR Z,ON1 + CP TGOSUB + JR Z,ON1 + LD E,TPROC + CP E + LD A,39 + JR NZ,ERROR2 ;"ON syntax" +ON1: LD D,A + EXX + PUSH HL + EXX + POP BC ;ON INDEX + LD A,B + OR H + OR L + JR NZ,ON4 ;OUT OF RANGE + OR C + JR Z,ON4 + DEC C + JR Z,ON3 ;INDEX=1 +ON2: CALL TERMQ + JR Z,ON4 ;OUT OF RANGE + INC IY ;SKIP DELIMITER + CP '"' + JR Z,ON5 + CP E + JR NZ,ON2 + DEC C + JR NZ,ON2 +ON3: LD A,E + CP TPROC + JR Z,ONPROC + PUSH DE + CALL ITEMI ;LINE NUMBER + POP DE + LD A,D + CP TGOTO + JR Z,GOTO2 + CALL SPAN ;SKIP REST OF LIST + JR GOSUB1 +; +ON5: CALL QUOTE + INC IY + JR ON2 +; +ON4: LD A,(IY) + INC IY + CP TELSE + JP Z,IF1 ;ELSE CLAUSE + CP CR + JR NZ,ON4 + LD A,40 +ERROR2: JP ERROR ;"ON range" +; +ONPROC: LD A,TON + JP PROC +; +;GOTO line +; +GOTO: CALL ITEMI ;LINE NUMBER +GOTO1: CALL TERMQ + JP NZ,SYNTAX +GOTO2: EXX + CALL FINDL + PUSH HL + POP IY + JP Z,XEQ0 + LD A,41 + JR ERROR2 ;"No such line" +; +;GOSUB line +; +GOSUB: CALL ITEMI ;LINE NUMBER +GOSUB1: PUSH IY ;TEXT POINTER + CALL CHECK ;CHECK ROOM + CALL GOTO1 ;SAVE MARKER +GOSCHK EQU $ +; +;RETURN +; +RETURN: POP DE ;MARKER + LD HL,GOSCHK + OR A + SBC HL,DE + POP IY + JR Z,XEQGO2 + LD A,38 + JR ERROR2 ;"No GOSUB" +; +;REPEAT +; +REPEAT: PUSH IY + CALL CHECK + CALL XEQ +REPCHK EQU $ +; +;UNTIL expr +; +UNTIL: POP BC + PUSH BC + LD HL,REPCHK + OR A + SBC HL,BC + JR Z,UNTIL1 + LD A,3 + CALL RESLOC + JR NZ,UNTIL + LD A,43 + JR ERROR2 ;"Not in a REPEAT loop" +; +UNTIL1: CALL EXPRI + CALL TEST + POP BC + POP DE + JR NZ,XEQGO2 ;TRUE + PUSH DE + PUSH BC + PUSH DE + POP IY +XEQGO2: JP XEQ +; +;FOR var = expr TO expr [STEP expr] +; +FORVAR: LD A,34 + JR ERROR2 ;"FOR variable" +; +FOR: CALL ASSIGN + JR NZ,FORVAR ;"FOR variable" + PUSH AF ;SAVE TYPE + LD A,(IY) + CP TTO + LD A,36 + JR NZ,ERROR2 ;"No TO" + INC IY + PUSH IX + CALL EXPRN ;LIMIT + POP IX + POP AF + LD B,A ;TYPE + PUSH BC ;SAVE ON STACK + PUSH HL + LD HL,0 + LD C,H + EXX + PUSH HL + LD HL,1 ;PRESET STEP + EXX + LD A,(IY) + CP TSTEP + JR NZ,FOR1 + INC IY + PUSH IX + CALL EXPRN ;STEP + POP IX +FOR1: LD B,8 ;FPP '>' + BIT 7,H + JR NZ,FOR2 ;STEP SIGN + LD B,12 ;FPP '<' +FOR2: PUSH BC + PUSH HL + EXX + PUSH HL + EXX + PUSH IY ;SAVE TEXT POINTER + PUSH IX ;LOOP VARIABLE + CALL CHECK + CALL XEQ +FORCHK EQU $ +; +;NEXT [var[,var...]] +; +NEXT: POP BC ;MARKER + LD HL,FORCHK + OR A + SBC HL,BC + JR Z,NEXT2 + PUSH BC + LD A,3 + CALL RESLOC + JR NZ,NEXT + LD A,32 + JR ERROR3 ;"Not in a FOR loop" +; +NEXT2: CALL TERMQ + POP HL + PUSH HL + PUSH BC + PUSH HL + CALL NZ,GETVAR ;VARIABLE + POP DE + EX DE,HL + OR A +NEXT0: SBC HL,DE + JR NZ,NEXT1 + PUSH DE + LD IX,6+2 + ADD IX,SP + CALL DLOAD5 ;STEP + LD A,(IX+11) ;TYPE + POP IX + CALL LOADN ;LOOP VARIABLE + PUSH AF + LD A,'+' AND 0FH + CALL FPP ;ADD STEP + JR C,ERROR3 + POP AF ;RESTORE TYPE + CALL STOREN ;UPDATE VARIABLE + LD IX,12 + ADD IX,SP + CALL DLOAD5 ;LIMIT + LD A,(IX-1) + CALL FPP ;TEST AGAINST LIMIT + JR C,ERROR3 + INC H + JR NZ,LOOP ;KEEP LOOPING + LD HL,18 + ADD HL,SP + LD SP,HL + CALL NLIST + JR NEXT +; +LOOP: POP BC + POP DE + POP IY + PUSH IY + PUSH DE + PUSH BC + JP XEQ +; +NEXT1: LD HL,18 + ADD HL,SP + LD SP,HL ;"POP" THE STACK + POP BC + LD HL,FORCHK + SBC HL,BC + POP HL ;VARIABLE POINTER + PUSH HL + PUSH BC + JR Z,NEXT0 + LD A,33 +ERROR3: JP ERROR ;"Can't match FOR" +; +;FNname +;N.B. ENTERED WITH A <> TON +; +FN: PUSH AF ;MAKE SPACE ON STACK + CALL PROC1 +FNCHK EQU $ +; +;PROCname +;N.B. ENTERED WITH A = ON PROC FLAG +; +PROC: PUSH AF ;MAKE SPACE ON STACK + CALL PROC1 +PROCHK EQU $ +PROC1: CALL CHECK + DEC IY + PUSH IY + CALL GETDEF + POP BC + JR Z,PROC4 + LD A,30 + JR C,ERROR3 ;"Bad call" + PUSH BC + LD HL,(PAGE) +PROC2: LD A,TDEF + CALL SEARCH ;LOOK FOR "DEF" + JR C,PROC3 + PUSH HL + POP IY + INC IY ;SKIP DEF + CALL NXT + CALL GETDEF + PUSH IY + POP DE + JR C,PROC6 + CALL NZ,CREATE + PUSH IY + POP DE + LD (HL),E + INC HL + LD (HL),D ;SAVE ADDRESS +PROC6: EX DE,HL + LD A,CR + LD B,A + CPIR ;SKIP TO END OF LINE + JR PROC2 +PROC3: POP IY ;RESTORE TEXT POINTER + CALL GETDEF + LD A,29 + JR NZ,ERROR3 ;"No such FN/PROC" +PROC4: LD E,(HL) + INC HL + LD D,(HL) ;GET ADDRESS + LD HL,2 + ADD HL,SP + CALL NXT ;ALLOW SPACE BEFORE ( + PUSH DE ;EXCHANGE DE,IY + EX (SP),IY + POP DE + CP '(' ;ARGUMENTS? + JP NZ,PROC5 + CALL NXT ;ALLOW SPACE BEFORE ( + CP '(' + JP NZ,SYNTAX ;"Syntax error" + PUSH IY + POP BC ;SAVE IY IN BC + EXX + EX AF,AF' + XOR A ;INITIALISE RETURN COUNT + EX AF,AF' + CALL SAVLOC ;SAVE DUMMY VARIABLES + EX AF,AF' + OR A + JR Z,RETCHK ;NO RETURNS + PUSH HL + NEG + LD L,A + NEG + LD H,-1 ;HL = -RETURNS + ADD HL,HL + ADD HL,HL + ADD HL,HL ;-RETURNS * 8 + EX (SP),HL + POP IX + ADD IX,SP + LD SP,IX + PUSH AF ;PUSH RETURN COUNT + CALL RETCHK ;PUSH MARKER +RETCHK: EX AF,AF' + CALL BRAKET ;CLOSING BRACKET + EXX + PUSH BC + POP IY ;RESTORE IY + PUSH HL + CALL ARGUE ;TRANSFER ARGUMENTS + POP HL +; +; If any of the dummy arguments is the same as a passed-by-reference +; variable, then it must not be restored on exit (it would overwrite +; the wanted returned values), therefore search the saved values on +; the stack and if a match is found set bit 4 of the type. On exit +; from the FN/PROC this will prevent the dummies from being restored. +; + EX (SP),HL + OR A + LD BC,RETCHK + SBC HL,BC + ADD HL,BC + EX (SP),HL + JR NZ,PROC5 ;No RETURNs +; + PUSH DE + PUSH HL + LD HL,7 ;Skip two PUSHes and RETCHK + ADD HL,SP + LD A,(HL) ;RETURN count + INC HL + PUSH HL + POP IX ;Address RETURNs table +PROC0: LD E,A + LD D,0 + EX DE,HL + ADD HL,HL + ADD HL,HL + ADD HL,HL + ADD HL,DE ;HL addresses SAVLOC stack + INC HL + INC HL ;Bump past LOCCHK +PROC7: LD E,(HL) + INC HL + LD D,(HL) ;DE = SAVLOC VARPTR + INC HL + LD C,(HL) ;Length (if string) + INC HL + LD B,(HL) ;Variable type +; +; Scan RETURNs table for VARPTR match +; + PUSH BC ;Save type + PUSH HL + PUSH IX + LD B,A ;B = RETURN count +PROC8: LD L,(IX+4) + LD H,(IX+5) ;HL = RETURNed VARPTR + OR A + SBC HL,DE + JR Z,PROC9 + EX DE,HL + LD DE,8 + ADD IX,DE + EX DE,HL + DJNZ PROC8 +PROC9: POP IX + POP HL + POP BC ;Restore type +; +; If match, set bit 4 of type: +; + JR NZ,PROCA + SET 4,(HL) ;Flag don't restore +; +; Increment past stacked data: +; +PROCA: LD DE,3 + BIT 6,B + JR NZ,PROCB ;Whole array + LD E,5 + BIT 7,B + JR Z,PROCB ;Numeric + LD E,C + INC DE +PROCB: ADD HL,DE + LD C,(HL) + INC HL + LD B,(HL) + INC HL ; BC = marker ? + EX DE,HL + LD HL,LOCCHK + OR A + SBC HL,BC + EX DE,HL + JR Z,PROC7 ;Another + POP HL + POP DE +; +PROC5: LD (HL),E ;SAVE "RETURN ADDRESS" + INC HL + LD A,(HL) + LD (HL),D + CP TON ;WAS IT "ON PROC" ? + JR NZ,XEQGO + PUSH DE + EX (SP),IY + CALL SPAN ;SKIP REST OF ON LIST + EX (SP),IY + POP DE + LD (HL),D + DEC HL + LD (HL),E +XEQGO: JP XEQ +; +LOCERR: INC IY + JR XEQGO +; +;LOCAL DATA +; +LOCDAT: INC IY + LD HL,(DATPTR) + PUSH HL + LD A,40H + PUSH AF + LD HL,DATPTR + PUSH HL + LD HL,LOCCHK + PUSH HL + JR XEQGO +; +;LOCAL var[,var...] +; +LOCAL: CP TERROR + JR Z,LOCERR + CP TDATA + JR Z,LOCDAT + POP BC + PUSH BC + LD HL,FNCHK + OR A + SBC HL,BC + JR Z,LOCAL1 + LD HL,PROCHK + OR A + SBC HL,BC + JR Z,LOCAL1 + LD HL,LOCCHK + OR A + SBC HL,BC + JR Z,LOCAL1 + LD HL,ARRCHK + OR A + SBC HL,BC + JR Z,LOCAL1 + LD HL,RETCHK + OR A + SBC HL,BC + LD A,12 + JP NZ,ERROR ;"Not LOCAL" +LOCAL1: PUSH IY + POP BC + EXX + DEC IY + CALL SAVLOC + EXX + PUSH BC + POP IY +LOCAL2: CALL GETVAR + JP NZ,SYNTAX + BIT 6,A ;ARRAY? + JR NZ,LOCAL4 + OR A ;TYPE + EX AF,AF' + CALL ZERO + EX AF,AF' + PUSH AF + CALL P,STOREN ;ZERO + POP AF + LD E,C + CALL M,STORES +LOCAL3: CALL NLIST + JR LOCAL2 +; +LOCAL4: LD (IX+0),1 ;FLAG LOCAL ARRAY + LD (IX+1),0 + JR LOCAL3 +; +;ENDPROC +; +ENDPRO: POP BC + LD HL,PROCHK ;PROC MARKER + XOR A + SBC HL,BC + JR Z,ENDPR1 + PUSH BC ;PUT BACK + CALL RESLOC + JR NZ,ENDPRO + LD A,13 + JP ERROR ;"No PROC" +; +ENDPR1: POP IY + JP XEQ +; +;INPUT #channel,var,var... +; +INPUTN: CALL CHNL ;E = CHANNEL NUMBER +INPN1: CALL NLIST + PUSH DE + CALL VAR + POP DE + PUSH AF ;SAVE TYPE + PUSH HL ;VARPTR + OR A + JP M,INPN2 ;STRING + CALL OSBGET + EXX + LD L,A + EXX + CALL OSBGET + EXX + LD H,A + EXX + CALL OSBGET + LD L,A + CALL OSBGET + LD H,A + CALL OSBGET + LD C,A + POP IX + POP AF ;RESTORE TYPE + PUSH DE ;SAVE CHANNEL + CALL STOREN + POP DE + JR INPN1 +INPN2: LD HL,ACCS +INPN3: CALL OSBGET + CP CR + JR Z,INPN4 + LD (HL),A + INC L + JR NZ,INPN3 +INPN4: POP IX + POP AF + PUSH DE + EX DE,HL + CALL STACCS + POP DE + JR INPN1 +; +;INPUT ['][SPC(x)][TAB(x[,y])]["prompt",]var[,var...] +;INPUT LINE [SPC(x)][TAB(x[,y])]["prompt",]var[,var...] +; +INPUT: CP '#' + JR Z,INPUTN + LD C,0 ;FLAG PROMPT + CP TLINE + JR NZ,INPUT0 + INC IY ;SKIP "LINE" + LD C,80H +INPUT0: LD HL,BUFFER + LD (HL),CR ;INITIALISE EMPTY +INPUT1: CALL TERMQ + JP Z,XEQ ;DONE + INC IY + CP ',' + JR Z,INPUT3 ;SKIP COMMA + CP ';' + JR Z,INPUT3 + PUSH HL ;SAVE BUFFER POINTER + CP '"' + JR NZ,INPUT6 + PUSH BC + CALL CONS + POP BC + CALL PTEXT ;PRINT PROMPT + JR INPUT9 +INPUT6: CALL FORMAT ;SPC, TAB, ' + JR NZ,INPUT2 +INPUT9: POP HL + SET 0,C ;FLAG NO PROMPT + JR INPUT0 +INPUT2: DEC IY + PUSH BC + CALL VAR + POP BC + POP HL + PUSH AF ;SAVE TYPE + LD A,(HL) + INC HL + CP CR ;BUFFER EMPTY? + CALL Z,REFILL + BIT 7,C + PUSH AF + CALL NZ,LINES + POP AF + CALL Z,FETCHS + POP AF ;RESTORE TYPE + PUSH BC + PUSH HL + OR A + JP M,INPUT4 ;STRING + PUSH AF + PUSH IX + CALL VAL0 + POP IX + POP AF + CALL STOREN + JR INPUT5 +INPUT4: CALL STACCS +INPUT5: POP HL + POP BC +INPUT3: RES 0,C + JR INPUT1 +; +REFILL: BIT 0,C + JR NZ,REFIL0 ;NO PROMPT + LD A,'?' + CALL OUTCHR ;PROMPT + LD A,' ' + CALL OUTCHR +REFIL0: LD HL,BUFFER + PUSH BC + PUSH HL + PUSH IX + CALL OSLINE + POP IX + POP HL + POP BC + LD B,A ;POS AT ENTRY + XOR A + LD (COUNT),A + CP B + RET Z +REFIL1: LD A,(HL) + CP CR + RET Z + INC HL + DJNZ REFIL1 + RET +; +;READ var[,var...] +; +READ: CP '#' + JP Z,INPUTN + LD HL,(DATPTR) +READ0: LD A,(HL) + CP ':' + CALL Z,REFIL1 + INC HL ;SKIP COMMA OR "DATA" + CP CR ;END OF DATA STMT? + CALL Z,GETDAT + PUSH HL + CALL VAR + POP HL + OR A + JP M,READ1 ;STRING + PUSH HL + EX (SP),IY + PUSH AF ;SAVE TYPE + PUSH IX + CALL EXPRN + POP IX + POP AF + CALL STOREN + EX (SP),IY + JR READ2 +READ1: CALL FETCHS + PUSH HL + CALL STACCS +READ2: POP HL + LD (DATPTR),HL + CALL NLIST + JR READ0 +; +GETDAT: CALL DSRCH + INC HL + RET NC + LD A,42 + JR ERROR4 ;"Out of DATA" +; +;IF expr statement +;IF expr THEN statement [ELSE statement] +;IF expr THEN line [ELSE line] +;IF expr THEN +; +IF: CALL EXPRI + CALL TEST + JR Z,IFNOT ;FALSE + LD A,(IY) + CP TTHEN + JP NZ,XEQ +IF0: INC IY ;SKIP "THEN" + LD A,(IY) + CP ';' + JR Z,IF0 +IF1: CALL NXT + CP TLINO + JP NZ,XEQ ;STATEMENT FOLLOWS + JP GOTO ;LINE NO. FOLLOWS +; +IFELSE: LD A,(IY) + INC IY + CP ';' + JR NZ,IFNEXT + JR IFTHEN +; +IF2: CALL QUOTE ;SKIP STRING +IFNOT: LD A,(IY) + INC IY +IFNEXT: CP '"' + JR Z,IF2 ;QUOTED STRING + CP TREM + JP Z,REM ;REM + CP CR + JP Z,XEQ0 ;END OF LINE + CP TELSE + JR Z,IF1 ;ELSE CLAUSE + CP TTHEN + JR NZ,IFNOT ;TRY FOR END AGAIN +IFTHEN: LD A,(IY) + CP CR + JR NZ,IFELSE + LD BC,TELSE + LD DE,TENDIF*256+TTHEN + INC IY + CALL NSCAN + JP Z,XEQ1 +NENDIF: LD A,49 +ERROR4: JP ERROR ;"Missing ENDIF" +; +; ELSE (multi-line) +; +MELSE: LD BC,-3 + ADD IY,BC + LD BC,TENDIF + LD DE,TENDIF*256+TTHEN + CALL NSCAN + JP Z,XEQ + JR NENDIF +; +; WHEN and OTHERWISE: +; +WHEN: LD BC,-3 + ADD IY,BC + LD BC,TENDCASE + LD DE,TENDCASE*256+TOF + CALL NSCAN + JP Z,XEQ + LD A,47 + JR ERROR4 ;"Missing ENDCASE" +; +; CASE +; +CASE: CALL EXPR ;String or numeric + EX AF,AF' + LD B,0 ;Flag numeric + JP P,CASE6 ;numeric + CALL PUSHS ;put string on stack + POP BC ;C = length + LD B,1 ;Flag string +CASE6: LD A,(IY) + INC IY + CP TOF + LD A,37 + JR NZ,ERROR4 ;"Missing OF" + LD A,(IY) + INC IY ;Address line-length byte + CP CR + LD A,48 + JR NZ,ERROR4 ;"OF not last" +CASE1: XOR A ;Level +CASE0: EXX + PUSH HL ;Push to stack + EXX + PUSH HL + PUSH BC + LD L,A ;Level + LD BC,TOTHERWISE*256+TWHEN + LD DE,TENDCASE*256+TOF + CALL NSCAN1 + POP BC ;Restore from stack + POP HL + EXX + POP HL + EXX + LD A,47 + JP NZ,ERROR ;Missing ENDCASE + LD A,(IY-1) + CP TENDCASE + JR Z,CASE9 + CP TOTHERWISE + JR Z,CASE9 +CASE4: BIT 0,B ;Numeric or string? + JR NZ,CASE3 + PUSH BC ;Type/exponent/length + PUSH HL ;MS 32 bits + EXX + PUSH HL ;LS 32 bits + EXX + CALL EXPRN + LD IX,0 + ADD IX,SP ;Address stack + EXX + LD E,(IX+0) ;Get LS 32-bits + LD D,(IX+1) + EXX + LD E,(IX+2) + LD D,(IX+3) ;Get MS 32-bits + LD B,(IX+4) ;Get exponent + LD A,9 + CALL FPP ;In case integer vs float + LD A,L + OR A ;NZ if equal + EXX + POP HL + EXX + POP HL + POP BC + JR NZ,CASE5 ;Match found +CASE2: LD A,(IY) + INC IY + CP ',' + JR Z,CASE4 ;Not found, try another + EXX + PUSH IY + EX (SP),HL + LD A,CR + LD B,A + CPIR ;Find CR + EX (SP),HL + POP IY + EXX + LD A,(IY-2) ;Last token in previous line + CP TOF ;CASE statement in WHEN line + JR NZ,CASE1 + LD A,1 + JR CASE0 +; +;Finished, level stack if string: +; +CASE9: BIT 0,B + JR Z,CASE8 + LD H,0 + LD L,C + ADD HL,SP + LD SP,HL +CASE8: JP XEQ +; +;Matched, so skip any more expressions: +; +CASE5: CALL NXT + CP ',' + JR NZ,CASE9 ;End of list + INC IY + PUSH BC ;Save type and string length + CALL EXPR ;Evaluate but discard + POP BC + JR CASE5 +; +;String compare: +; +CASE3: PUSH BC + CALL EXPRS + POP BC + LD HL,0 + ADD HL,SP + LD B,E + LD DE,ACCS + PUSH BC + CALL SCP ;String compare + POP BC + LD B,1 + JR NZ,CASE2 + JR CASE5 +; +; WHILE +; +WHILE: PUSH IY ;Save current position + CALL CHECK + CALL WHICHK ;Push marker +WHICHK: CALL EXPRI + CALL TEST + JR NZ,XEQGO5 + POP BC ;Pop marker + POP BC ;Level stack + LD BC,TWHILE+TENDWHILE*256 + LD D,1 + CALL WSRCH +XEQGO5: JP XEQ +; +; ENDWHILE +; +ENDWHI: POP BC ;Marker + POP DE ;Saved text pointer + PUSH DE + PUSH BC + OR A + LD HL,WHICHK + SBC HL,BC + JR Z,ENDWH1 + LD A,3 + CALL RESLOC + JR NZ,ENDWHI + LD A,46 + JR ERROR5 ;"Not in a WHILE loop" +; +ENDWH1: PUSH IY + LD IY,0 + ADD IY,DE + CALL EXPRI + CALL TEST + POP DE ;Text pointer + JR NZ,XEQGO5 + POP BC ;Junk marker + POP BC ;Junk pointer + LD IY,0 + ADD IY,DE + JR XEQGO5 +; +;CLS +; +CLS: CALL CLRSCN + XOR A + LD (COUNT),A + JP XEQ +; +;STOP +; +STOP: CALL TELL + DEFB CR + DEFB LF + DEFB TSTOP + DEFB 0 + CALL SETLIN ;FIND CURRENT LINE + CALL SAYLN + CALL CRLF + JP CLOOP +; +;REPORT +; +REPOR: CALL REPORT + JP XEQ +; +;CLEAR +; +CLR: CALL CLEAR + LD HL,(PAGE) + JR RESTR1 +; +;RESTORE ERROR +; +RESERR: INC IY + LD A,2 + CALL RESLOC + JP NZ,XEQ + LD A,53 ;ON ERROR not LOCAL +ERROR5: JP ERROR +; +;RESTORE DATA +; +RESDAT: INC IY + LD A,1 + CALL RESLOC + JP NZ,XEQ + LD A,54 ;'DATA not LOCAL' + DEFB 21H +NOLINE: LD A,41 ;'No such line' + JR ERROR5 +; +;RESTORE [line] +; +RESTOR: CP TERROR + JR Z,RESERR + CP TDATA + JR Z,RESDAT + CP '+' + JR Z,RESREL + LD HL,(PAGE) + CALL TERMQ + JR Z,RESTR1 + CALL ITEMI + EXX + CALL FINDL ;SEARCH FOR LINE + JR NZ,NOLINE +RESTR1: CALL DSRCH + LD (DATPTR),HL + JP XEQ +; +RESREL: CALL EXPRI + EXX + EX DE,HL + PUSH IY + POP HL + LD A,CR + LD B,A + CPIR ;FIND LINE END + DEC E + JR Z,RESTR1 + JP M,RESTR1 + XOR A + LD B,A +RESTR2: LD C,(HL) + CP C + JR Z,NOLINE + ADD HL,BC + DEC E + JR NZ,RESTR2 + JR RESTR1 +; +;PTR#channel=expr +;PAGE=expr +;TIME=expr +;LOMEM=expr +;HIMEM=expr +; +PTR: CALL CHANEL + CALL EQUALS + LD A,E + PUSH AF + CALL EXPRI + PUSH HL + EXX + POP DE + POP AF + CALL PUTPTR + JR XEQGO1 +; +PAGEV: CALL EQUALS + CALL EXPRI + EXX + LD L,0 + LD (PAGE),HL + JR XEQGO1 +; +TIMEV: CP '$' + JR Z,TIMEVS + CALL EQUALS + CALL EXPRI + PUSH HL + EXX + POP DE + CALL PUTIME + JR XEQGO1 +; +TIMEVS: INC IY ;SKIP '$' + CALL EQUALS + CALL EXPRS + CALL PUTIMS + JR XEQGO1 +; +LOMEMV: CALL EQUALS + CALL EXPRI + CALL CLEAR + EXX + LD (LOMEM),HL + LD (FREE),HL + JR XEQGO1 +; +HIMEMV: CALL EQUALS + CALL EXPRI + EXX + LD DE,(FREE) + INC D + XOR A + SBC HL,DE + ADD HL,DE + JP C,ERROR ;"No room" + LD DE,(HIMEM) + LD (HIMEM),HL + EX DE,HL + SBC HL,SP + JP NZ,XEQ + EX DE,HL + LD SP,HL ;LOAD STACK POINTER +XEQGO1: JP XEQ +; +;WIDTH expr +; +WIDTHV: CALL EXPRI + EXX + LD A,L + LD (WIDTH),A + JR XEQGO1 +; +;TRACE ON +;TRACE OFF +;TRACE line +; +TRACE: INC IY + LD HL,0 + CP TON + JR Z,TRACE0 + CP TOFF + JR Z,TRACE1 + DEC IY + CALL EXPRI + EXX +TRACE0: DEC HL +TRACE1: LD (TRACEN),HL + JR XEQGO1 +; +;VDU expr,expr;.... +; +VDU: CALL EXPRI + EXX + LD A,L + CALL OSWRCH + LD A,(IY) + CP ',' + JR Z,VDU2 + CP ';' + JR NZ,VDU3 + LD A,H + CALL OSWRCH +VDU2: INC IY +VDU3: CALL TERMQ + JR NZ,VDU + JR XEQGO1 +; +;CLOSE channel number +; +CLOSE: CALL CHANEL + CALL OSSHUT + JR XEQGO1 +; +;BPUT #channel,byte +;BPUT #channel,string[;] +; +BPUT: CALL CHANEL ;CHANNEL NUMBER + PUSH DE + CALL COMMA + CALL EXPR + EX AF,AF' + JP M,BPUTS + CALL SFIX + EXX + LD A,L + POP DE + CALL OSBPUT +BPUTX: JR XEQGO1 +; +BPUTS: LD A,E + POP DE + LD D,A + LD HL,ACCS +BPUTS1: LD A,(HL) + INC HL + CALL OSBPUT + DEC D + JR NZ,BPUTS1 + CALL NXT + CP ';' + INC IY + JR Z,BPUTX + LD A,LF + CALL OSBPUT + DEC IY + JR BPUTX +; +;CALL address[,var[,var...]] +; +CALL: CALL EXPRI ;ADDRESS + EXX + PUSH HL ;SAVE IT + LD B,0 ;PARAMETER COUNTER + LD DE,BUFFER ;VECTOR +CALL1: CALL NXT + CP ',' + JR NZ,CALL2 + INC IY + INC B + CALL NXT + PUSH BC + PUSH DE + CALL VAR + POP DE + POP BC + INC DE + LD (DE),A ;PARAMETER TYPE + INC DE + EX DE,HL + LD (HL),E ;PARAMETER ADDRESS + INC HL + LD (HL),D + EX DE,HL + JR CALL1 +CALL2: LD A,B + LD (BUFFER),A ;PARAMETER COUNT + POP HL ;RESTORE ADDRESS + CALL USR1 + JP XEQ +; +;USR(address) +; +USR: CALL ITEMI + EXX +USR1: PUSH HL ;ADDRESS ON STACK + EX (SP),IY + INC H ;PAGE &FF? + LD HL,USR2 ;RETURN ADDRESS + PUSH HL + LD IX,STAVAR + CALL Z,OSCALL ;INTERCEPT PAGE &FF + LD C,(IX+24) + PUSH BC + POP AF ;LOAD FLAGS + LD A,(IX+4) ;LOAD Z80 REGISTERS + LD B,(IX+8) + LD C,(IX+12) + LD D,(IX+16) + LD E,(IX+20) + LD H,(IX+32) + LD L,(IX+48) + LD IX,BUFFER + JP (IY) ;OFF TO USER ROUTINE +USR2: POP IY + XOR A + LD C,A + RET +; +; LEFT$(A$[,N]) = string +; MID$(A$,N[,M]) = string +; RIGHT$(A$[,N]) = string +; +LEFTSL: CALL GETSTR + LD HL,0FF00H ;Default all but last + JR NZ,MIDSL1 + JR MIDSL0 +; +RITESL: CALL GETSTR + LD HL,0FFFFH ;Default last char only + JR NZ,MIDSL1 + JR MIDSL0 +; +MIDSL: CALL GETSTR + LD A,5 + JP NZ,ERROR ;'Missing comma' + INC IY + PUSH IX + CALL EXPRI + POP IX + EXX + CALL NXT + DEC L + LD H,254 ;Default rest of string + CP ',' + JR NZ,MIDSL1 +MIDSL0: INC IY + PUSH HL + PUSH IX + CALL EXPRI + POP IX + EXX + LD A,L + POP HL + OR A + JR Z,MIDSL2 ;Zero length + DEC A + ADD A,L + LD H,A + JR NC,MIDSL1 + LD A,L + INC A + JR Z,MIDSL1 + LD H,254 + JR MIDSL1 +; +MIDSL2: LD HL,1 +MIDSL1: CALL BRAKET + CALL EQUALS + PUSH HL + PUSH IX + CALL EXPRS + POP IX + POP HL + LD C,E + LD B,(IX+0) + LD E,(IX+2) + LD D,(IX+3) +; +; Source string at ACCS, length C +; Destination string at DE, length B +; L = first character to modify 0-254 +; H = last character to modify 0-254 +; IF L=255 THEN modify rightmost H + 2 chars +; ELSE IF H=255 modify all but last character +; ELSE IF L > H do nothing +; IX = destination VARPTR +; + LD A,L + INC A + JR NZ,SUBSL1 + INC H + INC H + LD A,C + CP H + JR NC,SUBSL0 + LD H,A +SUBSL0: LD A,B + SUB H + JR NC,SUBSL6 + XOR A +SUBSL6: LD L,A + JR SUBSL5 +; +SUBSL1: LD A,H + INC A + JR NZ,SUBSL2 + LD A,B + SUB 2 + JR C,SUBSL9 + LD H,A +SUBSL2: LD A,L + CP B + JR NC,SUBSL9 + LD A,H + CP B + JR C,SUBSL3 +SUBSL5: LD A,B + DEC A + LD H,A +SUBSL3: LD A,H + SUB L + JR C,SUBSL9 + INC A + CP C + JR C,SUBSL4 + LD A,C +SUBSL4: LD B,0 + LD H,B + LD C,A + OR A + JR Z,SUBSL9 + EX DE,HL + ADD HL,DE + EX DE,HL + LD HL,ACCS + LDIR +SUBSL9: JP XEQ +; +; EXIT FOR [var] +; EXIT REPEAT +; EXIT WHILE +; +EXIT: INC IY ;Skip FOR/REPEAT/WHILE + CP TFOR + JR NZ,EXIT0 + LD IX,0 ;For EXIT FOR + CALL TERMQ + CALL NZ,GETVAR + LD A,TFOR +EXIT0: LD D,1 ;Level for WSRCH + LD E,A +EXIT1: LD A,E + POP BC ;Marker + LD HL,FORCHK + OR A + SBC HL,BC + JR Z,EXIT4 + LD HL,REPCHK + OR A + SBC HL,BC + JR Z,EXIT6 + LD HL,WHICHK + OR A + SBC HL,BC + JR Z,EXIT7 + PUSH BC ;Put back marker + PUSH IX + POP BC + EXX + LD A,3 + CALL RESLOC + EXX + PUSH BC + POP IX + JR NZ,EXIT1 + LD A,44 + JP ERROR ;'Bad EXIT' +; +EXIT4: POP BC ;VARPTR + LD HL,14 ;Skip text pointer, limit & step + ADD HL,SP + LD SP,HL ;Pop FOR record + CP TFOR + JR NZ,EXIT1 + PUSH IX + POP HL + LD A,H + OR L + JR Z,EXIT5 + SBC HL,BC +EXIT5: LD BC,TFOR+TNEXT*256 + JR Z,EXIT8 + INC D ;Count nested FOR loops + JR EXIT1 +; +EXIT6: POP BC ;Text pointer + CP TREPEAT + JR NZ,EXIT1 + LD BC,TREPEAT+TUNTIL*256 + JR EXIT8 +; +EXIT7: POP BC ;Text pointer + CP TWHILE + JR NZ,EXIT1 + LD BC,TWHILE+TENDWHILE*256 +EXIT8: CALL WSRCH + CALL SPAN ;Skip UNTIL expression + JP XEQ +; +;PUT port,data +; +PUT: CALL EXPRI ;PORT ADDRESS + EXX + PUSH HL + CALL COMMA + CALL EXPRI ;DATA + EXX + POP BC + OUT (C),L ;OUTPUT TO PORT BC + JP XEQ +; +;SUBROUTINES: +; +;ASSIGN - Assign a numeric value to a variable. +;Outputs: NC, Z - OK, numeric scalar +; NC, NZ, PE - OK, string array (D = type, E = operator) +; else if NC, NZ, P - OK, numeric array (D = type, E = operator) +; else if NC, NZ - OK, string scalar +; C, NZ - illegal / invalid +; +ASSIGN: CALL GETVAR ;VARIABLE + RET C ;ILLEGAL VARIABLE + CALL NZ,PUTVAR + LD D,A ;Type + CALL NXT + INC IY + LD E,A ;Operator (or =) + CP '=' + CALL NZ,EQUALS + LD A,D + AND 11000000B + RET NZ ;String or array + PUSH DE + PUSH HL + CALL EXPRN + POP IX + POP DE +; +; Falls through to... +; +; MODIFY - Update numeric variable according to operator: +; Inputs: D = type +; E = operator +; HLH'L'C = value +; IX = destination VARPTR +; Destroys: Everything except IX,IY,SP +; +MODIFY: LD A,E + CP '=' + JR Z,STORE0 ;Simple assignment + PUSH DE + EXX + EX DE,HL + EXX + EX DE,HL + LD B,C + EX (SP),HL + LD A,H + EX (SP),HL + CALL LOADN + EX (SP),HL + LD A,L + EX (SP),HL + AND 15 + PUSH IX + CALL FPP + POP IX + POP DE + JP C,ERROR +STORE0: LD A,D ;Type +STOREN: CP 5 + JR Z,STORE5 + PUSH AF + INC C ;SPEED - & PRESERVE F' + DEC C ; WHEN CALLED BY FNEND0 + CALL NZ,SFIX ;CONVERT TO INTEGER + POP AF + CP 4 + JR Z,STORE4 + CP A ;SET ZERO +STORE1: EXX + LD (IX+0),L + EXX + RET +; +STORE5: LD (IX+4),C +STORE4: EXX + LD (IX+0),L + LD (IX+1),H + EXX + LD (IX+2),L + LD (IX+3),H + RET +; +; MODIFS - Update string variable according to operator: +; Inputs: H = type +; L = operator (= or +) +; E = string length (string in accumulator) +; IX = destination VARPTR +; Destroys: Everything except SP, IY +; +MODIFS: LD A,L ;Operator + CP '+' + LD A,H ;Type + JR NZ,STACCS + PUSH IY + PUSH IX + POP IY + CALL PUSHS + PUSH IY + POP IX + CALL LOADS + POP BC + LD A,B ;Type + INC C + DEC C + JR Z,MODFS1 ;Zero length + LD HL,0 + LD B,H + ADD HL,SP + LDIR + LD SP,HL +MODFS1: POP IY +; +; Falls through to: +; +STACCS: LD HL,ACCS +STORES: RRA + JR NC,STORS3 ;FIXED STRING + PUSH HL + CALL LOAD4 + LD A,E ;LENGTH OF STRING + EXX + LD L,A + LD A,H ;LENGTH ALLOCATED + EXX + CP E + JR NC,STORS1 ;ENOUGH ROOM + EXX + LD H,L + EXX + PUSH HL + LD B,0 + LD C,A + ADD HL,BC + LD BC,(FREE) + SBC HL,BC ;IS STRING LAST? + POP HL + JR Z,STORS0 + LD H,B + LD L,C ;DESTINATION +; + OR A ;V5 optimisation + JR Z,STORS0 + LD A,E +STORS2: LD E,A + DEC E + AND E + JR NZ,STORS2 + SCF + RL E + LD A,E + EXX + LD H,A + EXX +; +STORS0: SCF +STORS1: CALL STORE4 ;PRESERVES CARRY! + LD B,0 + LD C,E + EX DE,HL + POP HL + DEC C + INC C + RET Z ;NULL STRING + LDIR + RET NC ;STRING REPLACED + LD (FREE),DE +CHECK: PUSH HL + LD HL,(FREE) + INC H + SBC HL,SP + POP HL + RET C + XOR A + JP ERROR ;"No room" +; +STORS3: LD C,E + PUSH IX + POP DE + XOR A + LD B,A + CP C + JR Z,STORS5 + LDIR +STORS5: LD A,CR + LD (DE),A + RET +; +; SAVRET - SAVE 'RETURNed' PARAMETER INFO +; +SAVRET: LD (IX+0),L ;Formal VARPTR + LD (IX+1),H + LD (IX+2),A + EX (SP),IY + PUSH AF + PUSH IY + PUSH IX + CALL NXT + CALL VAR + POP IX + LD (IX+4),L ;Actual VARPTR + LD (IX+5),H + LD (IX+6),A + POP IY + POP AF + LD BC,8 + ADD IX,BC + JR ARGUE0 +; +;ARGUE: TRANSFER FN OR PROC ARGUMENTS FROM THE +; CALLING STATEMENT TO THE DUMMY VARIABLES VIA +; THE STACK. IT MUST BE DONE THIS WAY TO MAKE +; PROCFRED(A,B) DEF PROCFRED(B,A) WORK. +; Inputs: DE addresses parameter list +; IY addresses dummy variable list +; IX addresses RETURNed parameter data block +; Outputs: DE,IY updated +; Destroys: Everything +; +ARGUE: LD A,-1 + PUSH AF ;PUT MARKER ON STACK +ARGUE1: INC IY ;BUMP PAST ( OR , + INC DE + PUSH DE + LD B,0 + CALL NXT + CP TRETURN + JR NZ,ARGUE9 + INC IY ;SKIP 'RETURN' + CALL NXT + INC B ;FLAG 'RETURN' +ARGUE9: PUSH BC + PUSH IX + CALL GETVAR ;FORMAL PARAMETER + JR C,ARGERR + CALL NZ,PUTVAR + POP IX + POP BC + POP DE + PUSH HL ;VARPTR + PUSH AF + PUSH DE + DEC B + JR Z,SAVRET + EX (SP),IY +ARGUE0: BIT 6,A ;ARRAY? + JR NZ,ARGUE3 + OR A ;TYPE + JP M,ARGUE2 ;STRING + PUSH IX + CALL EXPRN ;ACTUAL PARAMETER + POP IX + EX (SP),IY + POP DE + POP AF + EXX + PUSH HL + EXX + PUSH HL + LD B,A + PUSH BC + JR ARGUE4 +; +ARGUE2: PUSH IX + CALL EXPRS + EXX + POP BC + EX (SP),IY + POP DE + EXX + POP AF + CALL PUSHS + EXX + PUSH BC + POP IX +ARGUE4: CALL NXT + CP ',' + JR NZ,ARGUE5 + LD A,(DE) + CP ',' + JR Z,ARGUE1 ;ANOTHER +ARGERR: LD A,31 + JP ERROR ;"Bad arguments" +; +ARGUE3: PUSH IX + CALL NXT + CALL GETVAR + JR C,ARGERR + LD C,(IX+0) + LD B,(IX+1) + POP IX + CALL NXT + EX (SP),IY + POP DE + POP AF + PUSH BC ;STACK ARRAY POINTER + PUSH AF ;STACK TYPE + JR ARGUE4 +; +ARGUE5: CALL BRAKET + LD A,(DE) + CP ')' + JR NZ,ARGERR + INC DE +UNSTAK: EXX +ARGUE6: POP BC + LD A,B + INC A + EXX + RET Z ;MARKER POPPED + EXX + DEC A + BIT 6,A ;ARRAY + JR NZ,ARGUE8 + OR A + JP M,ARGUE7 ;STRING + POP HL + EXX + POP HL + EXX + POP IX + CALL STOREN ;WRITE TO DUMMY + JR ARGUE6 +; +ARGUE7: CALL POPS + POP IX + CALL STACCS + JR ARGUE6 +; +ARGUE8: POP BC ;ARRAY POINTER + POP IX + LD (IX+0),C + LD (IX+1),B + JR ARGUE6 +; +;Restore RETURNed parameters, via the stack to ensure that +; PROCFRED(A,B) DEF PROCFRED(RETURN B,RETURN A) works. +; +RETXFR: LD A,-1 + PUSH AF ;PUT MARKER ON STACK +RETXF1: EXX + LD L,(IX+4) ;Actual parameter (destination) + LD H,(IX+5) + PUSH HL ;STACK VARPTR + LD L,(IX+0) ;Formal parameter (source) + LD H,(IX+1) + LD A,(IX+2) + BIT 6,A ;ARRAY? + JR NZ,RETXF3 + OR A ;TYPE + JP M,RETXF2 ;STRING + PUSH HL + EX (SP),IX + CALL LOADN + POP IX + EXX ;STACK VALUE + PUSH HL + EXX + PUSH HL +RETXF6: LD B,(IX+6) + PUSH BC ;TYPE & EXPONENT +RETXF5: CALL CHECK ;CHECK ROOM + JR RETXF4 +; +RETXF3: LD E,(HL) + INC HL + LD D,(HL) + PUSH DE ;STACK ARRAY POINTER + JR RETXF6 +; +RETXF2: PUSH HL + EX (SP),IX + CALL LOADS + POP IX + LD A,(IX+6) + EXX + PUSH IX + POP HL + EXX + CALL PUSHS + EXX + PUSH HL + POP IX + EXX +RETXF4: LD DE,8 + ADD IX,DE + EXX + DJNZ RETXF1 + JP UNSTAK +; +;Restore 'RETURNed' parameters, +; +RESRET: POP BC ;B = 'RETURN' COUNT + LD H,0 + LD L,B + ADD HL,HL + ADD HL,HL + ADD HL,HL ;RETURN COUNT * 8 + ADD HL,SP + LD IX,0 + ADD IX,SP ;ADDRESS PARAMETER LIST + PUSH AF + PUSH DE + PUSH HL + EXX + PUSH BC + PUSH DE + EXX + LD A,B + LD HL,ACCS + LD DE,BUFFER + LD BC,255 + LDIR + LD B,A + CALL RETXFR ;TRANSFER VIA STACK + LD HL,BUFFER + LD DE,ACCS + LD BC,255 + LDIR + EXX + POP DE + POP BC + EXX + POP HL + POP DE + POP AF + JR RESAR1 +; +; Restore LOCAL array or memory block: +; +RESARR: POP BC + BIT 7,B ;String array? + POP HL + POP BC + ADD HL,BC + ADD HL,SP + CALL NZ,FREESA ;Free string array +RESAR1: LD SP,HL + JR RESLO1 +; +; RESLOC - Restore local variables/arrays or DATA/ERROR status from stack +; Inputs: A = 0 if everything OK, bit0 set if DATPTR, bit1 set if ERRTRP +; Outputs: Z if nothing was restored, NZ if something was restored +; Destroys: A,B,C,D,E,H,L,H',L',IX,SP,flags +; +RESLOC: POP DE ;Return address + LD IX,0 ;To flag nothing was restored +RESLO1: POP BC ;Marker ? + LD HL,LOCCHK + OR A + SBC HL,BC + JR Z,RESLO2 ;Something to restore + OR A + JR NZ,RESLO8 + LD HL,RETCHK + SBC HL,BC + JR Z,RESRET + LD HL,ARRCHK + OR A + SBC HL,BC + JR Z,RESARR +RESLO8: PUSH IX + POP HL + LD A,H + OR L +RESLO0: PUSH BC ;Put back marker + EX DE,HL + JP (HL) ;Return +; +RESLO2: POP IX ;Variable pointer + OR A + JR Z,RESLO3 ;Everything allowed + PUSH IX + POP BC + BIT 0,A + JR Z,RESLO6 ;Bit 0 set, so + LD HL,DATPTR ;test for DATPTR + SBC HL,BC + JR Z,RESLO3 +RESLO6: OR A + BIT 1,A + JR Z,RESLO7 ;Bit 1 set, so + LD HL,ERRTRP ;test for ERRPTR + SBC HL,BC + JR Z,RESLO3 +RESLO7: PUSH BC ;Put back pointer + LD BC,LOCCHK + JR RESLO0 +; +RESLO3: POP BC ;Type / exponent + BIT 6,B + JR NZ,RESLO4 ;Array? + BIT 7,B + JR NZ,RESLO5 ;String? + POP HL + EXX + POP HL + EXX + BIT 4,B + JR NZ,RESLO1 + PUSH AF + LD A,B + CALL STOREN ;Numeric + POP AF + JR RESLO1 +; +RESLO4: POP HL + BIT 4,B + JR NZ,RESLO1 + LD (IX+0),L ;Array + LD (IX+1),H + JR RESLO1 +; +RESLO9: LD B,0 + ADD HL,BC + LD SP,HL +RESLGO: JR RESLO1 +; +RESLO5: LD HL,0 + ADD HL,SP + BIT 4,B + JR NZ,RESLO9 + PUSH AF + PUSH DE + LD E,C + LD A,B + CALL STORES ;String + POP DE + POP AF + LD SP,HL + JR RESLGO +; +;SAVLOC: SUBROUTINE TO STACK LOCAL PARAMETERS +; OF A FUNCTION OR PROCEDURE. +;THERE IS A LOT OF STACK MANIPULATION - CARE!! +; Inputs: IY is parameters pointer +; Outputs: IY updated +; A' incremented for each RETURN +; Destroys: A',A,B,C,D,E,H,L,IX,IY,F,SP +; +SAVLOC: POP DE ;RETURN ADDRESS +SAVLO1: INC IY ;BUMP PAST ( OR , + CALL NXT + CP TRETURN + JR NZ,SAVLO6 + EX AF,AF' + INC A ;RETURN counter + EX AF,AF' + INC IY ;Bump past RETURN + CALL NXT +SAVLO6: PUSH DE + EXX + PUSH BC + PUSH DE + PUSH HL + EXX + CALL VAR ;DUMMY VARIABLE + EXX + POP HL + POP DE + POP BC + EXX + POP DE + BIT 6,A ;ARRAY? + JR NZ,SAVLO3 + OR A ;TYPE + JP M,SAVLO2 ;STRING + EXX + PUSH HL ;SAVE H'L' + EXX + LD B,A ;TYPE + CALL LOADN + EXX + EX (SP),HL + EXX + PUSH HL + PUSH BC + JR SAVLO4 +; +SAVLO3: LD C,(IX+0) ;ARRAY POINTER + LD B,(IX+1) + PUSH BC ;SAVE TO STACK + PUSH AF ;SAVE TYPE + JR SAVLO4 +; +SAVLO2: PUSH AF ;STRING TYPE + PUSH DE + EXX + PUSH HL + EXX + CALL LOADS + EXX + POP HL + EXX + LD C,E + POP DE + CALL CHECK + POP AF ;LEVEL STACK + LD HL,0 + LD B,L + SBC HL,BC + ADD HL,SP + LD SP,HL + LD B,A ;TYPE + PUSH BC + JR Z,SAVLO4 + PUSH DE + LD DE,ACCS + EX DE,HL + LD B,L + LDIR ;SAVE STRING ON STACK + POP DE +SAVLO4: PUSH IX ;VARPTR + CALL SAVLO5 +LOCCHK EQU $ +SAVLO5: CALL CHECK + CALL NXT + CP ',' ;MORE? + JR Z,SAVLO1 + EX DE,HL + JP (HL) ;"RETURN" +; +TERMQ: CALL NXT + CP TELSE + RET NC + CP ':' ;ASSEMBLER SEPARATOR + RET NC + CP CR + RET +; +SPAN: CALL TERMQ + RET Z + INC IY + CP '"' + CALL Z,QUOTE + JR SPAN +; +EQUALS: CALL NXT + INC IY + CP '=' + RET Z + LD A,4 + JP ERROR ;"Mistake" +; +FORMAT: CP TTAB + JR Z,DOTAB + CP TSPC + JR Z,DOSPC + CP '''' + RET NZ + CALL CRLF + XOR A + RET +; +DOTAB: PUSH BC + CALL EXPRI + EXX + POP BC + LD A,(IY) + CP ',' + JR Z,DOTAB1 + CALL BRAKET + LD A,L +TABIT: LD HL,COUNT + CP (HL) + RET Z + PUSH AF + CALL C,CRLF + POP AF + SUB (HL) + JR SPACES +DOTAB1: INC IY + PUSH BC + PUSH HL + CALL EXPRI + EXX + POP DE + POP BC + CALL BRAKET + CALL PUTCSR + XOR A + RET +; +DOSPC: PUSH BC + CALL ITEMI + EXX + LD A,L + POP BC +SPACES: OR A + RET Z + PUSH BC + LD B,A +FILL1: LD A,' ' + CALL OUTCHR + DJNZ FILL1 + POP BC + XOR A + RET +; +PTEXT: LD HL,ACCS + INC E +PTEXT1: DEC E + RET Z + LD A,(HL) + INC HL + CALL OUTCHR + JR PTEXT1 +; +FETCHS: PUSH AF + PUSH BC + PUSH HL + EX (SP),IY + CALL XTRACT + CALL NXT + EX (SP),IY + POP HL + POP BC + POP AF + RET +; +LINES: LD DE,ACCS +LINE1S: LD A,(HL) + LD (DE),A + CP CR + RET Z + INC HL + INC E + JR LINE1S +; +XTRACT: CALL NXT + CP '"' + INC IY + JP Z,CONS + DEC IY + LD DE,ACCS +XTRAC1: LD A,(IY) + LD (DE),A + CP ',' + RET Z + CP CR + RET Z + INC IY + INC E + JR XTRAC1 +; +DSRCH: LD A,TDATA +SEARCH: LD B,0 +SRCH1: LD C,(HL) + INC C + DEC C + JR Z,SRCH2 ;FAIL + INC HL + INC HL + INC HL + CP (HL) + RET Z + DEC C + DEC C + DEC C + ADD HL,BC + JP SRCH1 +SRCH2: DEC HL ;POINT TO CR + SCF + RET +; +; NSCAN - scan for token at start of line, with nesting of inner structures +; Alternative entry at NSCAN1 with L = level (used by CASE) +; +; Inputs: B = token to find (1, start of line) +; C = token to find (2, start of line) +; E = token to nest (end of line) +; D = token to unnest (start of line) +; IY = start search area (line length byte) +; Outputs: NZ if not found +; Z if found, IY points to byte after token +; Destroys: A,B,C,L,IY,F +; +NSCAN: LD L,0 ;nest level +NSCAN1: LD A,(IY) ;get line length + OR A ;test zero = end of prog + JR Z,NSCAN6 + LD A,(IY+3) ;initial token + CP B ;test value reqd + JR Z,NSCAN3 ;found (1) + CP C + JR Z,NSCAN3 ;found (2) +NSCAN7: CP D ;unnest? + JR Z,NSCAN5 +NSCAN2: PUSH BC + LD B,0 + LD C,(IY) + ADD IY,BC ;go to next line + LD A,(IY-2) + CP E ;nest? + LD A,C + POP BC + JR NZ,NSCAN1 ;continue + CP 5 ;empty line ? + JR C,NSCAN1 ;continue + INC L ;increment nest level + JR NSCAN1 ;continue +; +NSCAN3: INC L + DEC L + JR NZ,NSCAN7 +NSCAN4: LD BC,4 + ADD IY,BC + XOR A ;Z + RET +; +NSCAN5: DEC L ;decrement nest level + JP P,NSCAN2 + JR NSCAN4 +; +NSCAN6: OR 1 ;NZ + RET +; +; WSRCH - search for token, with nesting of inner structures +; +; Inputs: B = token to find or unnest (anywhere) +; C = token to nest (anywhere), ignore after EXIT +; D = ordinal (1 = find first token, 2 = second) +; IY = address to start looking +; Outputs: IY points to byte after that found +; if not found abort to END +; Destroys: A,D,IY,F +; +WSRCH: LD A,(IY) + INC IY + CP '"' + CALL Z,QUOTE + CP TREM + JR Z,WSRCHM + CP TEXIT + JR Z,WSRCHE + CP B + JR Z,WSRCHX + CP C + JR Z,WSRCHP + CP CR + JR NZ,WSRCH +WSRCH1: LD A,(IY) ;Line length + INC IY + OR A + JP Z,END + INC IY + INC IY ;Skip line number + LD A,(IY) + CP TDATA + JR NZ,WSRCH +WSRCHM: LD A,(IY) + INC IY + CP CR + JR NZ,WSRCHM ;Skip to end of line + JR WSRCH1 +; +WSRCHP: INC D + JR WSRCH +; +WSRCHX: DEC D + JR NZ,WSRCH + RET +; +WSRCHE: CALL NXT + INC IY + JR WSRCH +; +; QUOTE - skip quoted string +; +QUOTE: LD A,(IY) + INC IY + CP CR + JP Z,MISQUO + CP '"' + JR NZ,QUOTE + RET +; +MISQUO: LD A,9 + JP ERROR ;"Missing quote" +; +; X14OR5 - multiply by 1, 4 or 5 +; Inputs: DE = number to be multiplied +; A = 1, 4 or 5 (else multiply by 4) +; Outputs: DE = DE * A +; Carry set if overflow +; Destroys: D,E,H,L,F +; +X14OR5: LD H,D + LD L,E + CP 1 + RET Z + CP 5 + ADD HL,HL + RET C + ADD HL,HL + RET C + EX DE,HL + RET NZ + ADD HL,DE + EX DE,HL + RET +; +; MUL16 - 16-bit multiply +; Inputs: HL = number to be multiplied +; BC = multiplier +; Outputs: HL = HL * BC +; Carry set if overflow +; Destroys: A,D,E,H,L,F +; +MUL16: EX DE,HL + LD HL,0 + LD A,16 +MUL161: ADD HL,HL + RET C ;OVERFLOW + SLA E + RL D + JR NC,MUL162 + ADD HL,BC + RET C +MUL162: DEC A + JR NZ,MUL161 + RET +; +CHANEL: CALL NXT + CP '#' + LD A,45 + JP NZ,ERROR ;"Missing #" +CHNL: INC IY ;SKIP '#' + CALL ITEMI + EXX + EX DE,HL + RET +; +; FREESA - Free members of a string array if adjacent to the top of heap +; Inputs: BC = length of array (= 4 * number of elements) +; HL addresses array first byte *above* array +; Outputs: NZ if any array element freed, Z if none +; Destroys: nothing +; +FREESA: PUSH AF +FREES0: PUSH BC + PUSH DE + PUSH HL + XOR A + LD D,B + LD E,C + LD B,A +FREES1: PUSH DE + DEC HL + LD D,(HL) + DEC HL + LD E,(HL) + DEC HL + LD C,(HL) + DEC HL + PUSH HL + LD HL,(FREE) + EX DE,HL + ADD HL,BC + SBC HL,DE + JR NZ,FREES2 + ADD HL,DE + SBC HL,BC + LD (FREE),HL + OR H +FREES2: POP DE + POP HL + LD C,4 + OR A + SBC HL,BC + EX DE,HL + JR NZ,FREES1 + OR A + POP HL + POP DE + POP BC + OR A + JR NZ,FREES0 + POP AF + RET +; + END diff --git a/src/HOOK.Z80 b/src/HOOK.Z80 new file mode 100644 index 0000000..0d38dae --- /dev/null +++ b/src/HOOK.Z80 @@ -0,0 +1,63 @@ +; + GLOBAL CLG + GLOBAL COLOUR + GLOBAL DRAW + GLOBAL ENVEL + GLOBAL GCOL + GLOBAL MODE + GLOBAL MOVE + GLOBAL PLOT + GLOBAL SOUND + GLOBAL PUTIMS + GLOBAL CIRCLE + GLOBAL ELLIPSE + GLOBAL FILL + GLOBAL MOUSE + GLOBAL ORIGIN + GLOBAL RECTAN + GLOBAL LINE + GLOBAL TINT + GLOBAL WAIT + GLOBAL SYS +; + GLOBAL ADVAL + GLOBAL POINT + GLOBAL GETIMS + GLOBAL TINTFN + GLOBAL MODEFN + GLOBAL WIDFN +; + EXTRN EXTERR +; +CLG: +COLOUR: +DRAW: +ENVEL: +GCOL: +MODE: +MOVE: +PLOT: +SOUND: +ADVAL: +POINT: +GETIMS: +PUTIMS: +CIRCLE: +ELLIPSE: +FILL: +MOUSE: +ORIGIN: +RECTAN: +LINE: +TINT: +TINTFN: +MODEFN: +WIDFN: +WAIT: +SYS: + XOR A + CALL EXTERR + DEFM 'Sorry' + DEFB 0 +; + END diff --git a/src/MAIN.Z80 b/src/MAIN.Z80 new file mode 100644 index 0000000..1d2e026 --- /dev/null +++ b/src/MAIN.Z80 @@ -0,0 +1,2236 @@ + TITLE BBC BASIC (C) R.T.RUSSELL 1981-2024 +; +;BBC BASIC INTERPRETER - Z80 VERSION +;COMMANDS AND COMMON MODULE - "MAIN" +;(C) COPYRIGHT R.T.RUSSELL 1981-2024 +; +;THE NAME BBC BASIC IS USED WITH THE PERMISSION +;OF THE BRITISH BROADCASTING CORPORATION AND IS +;NOT TRANSFERRABLE TO A FORKED OR DERIVED WORK. +; +;VERSION 2.3, 07-05-1984 +;VERSION 3.0, 01-03-1987 +;VERSION 5.0, 27-05-2024 +; + EXTRN XEQ + EXTRN RUN0 + EXTRN CHAIN0 + EXTRN TERMQ + EXTRN MUL16 + EXTRN X14OR5 + EXTRN SPACES + EXTRN ESCAPE + EXTRN CHECK + EXTRN SEARCH +; + EXTRN OSWRCH + EXTRN OSLINE + EXTRN OSINIT + EXTRN OSLOAD + EXTRN OSSAVE + EXTRN OSBGET + EXTRN OSBPUT + EXTRN OSSHUT + EXTRN OSSTAT + EXTRN PROMPT + EXTRN LTRAP + EXTRN OSCLI + EXTRN RESET +; + EXTRN COMMA + EXTRN BRAKET + EXTRN ZERO + EXTRN ITEMI + EXTRN EXPRI + EXTRN EXPRS + EXTRN DECODE + EXTRN LOADN + EXTRN SFIX +; + GLOBAL NXT + GLOBAL NLIST + GLOBAL START + GLOBAL OUTCHR + GLOBAL OUT + GLOBAL ERROR + GLOBAL EXTERR + GLOBAL REPORT + GLOBAL CLOOP + GLOBAL WARM + GLOBAL CLEAR + GLOBAL CRLF + GLOBAL SAYLN + GLOBAL LOAD0 + GLOBAL TELL + GLOBAL FINDL + GLOBAL GETTOP + GLOBAL SETLIN + GLOBAL GETVAR + GLOBAL PUTVAR + GLOBAL GETDEF + GLOBAL LOCATE + GLOBAL CREATE + GLOBAL PBCDL + GLOBAL LEXAN2 + GLOBAL RANGE + GLOBAL VERMSG + GLOBAL KEYWDS + GLOBAL KEYWDL +; + EXTRN PAGE + EXTRN ACCS + EXTRN BUFFER + EXTRN LOMEM + EXTRN HIMEM + EXTRN COUNT + EXTRN WIDTH + EXTRN FREE + EXTRN STAVAR + EXTRN DYNVAR + EXTRN ERRTXT + EXTRN ERR + EXTRN ERL + EXTRN CURLIN + EXTRN ERRTRP + EXTRN ONERSP + EXTRN FNPTR + EXTRN PROPTR + EXTRN AUTONO + EXTRN INCREM + EXTRN LISTON + EXTRN TRACEN +; +CR EQU 0DH +LF EQU 0AH +ESC EQU 1BH +; +TERROR EQU 85H +TLINE EQU 86H +TELSE EQU 8BH +TTHEN EQU 8CH +TLINO EQU 8DH +TFN EQU 0A4H +TTO EQU 0B8H +TWHILE EQU 0C7H +TCASE EQU 0C8H +TWHEN EQU 0C9H +TOF EQU 0CAH +TENDCASE EQU 0CBH +TOTHERWISE EQU 0CCH +TENDIF EQU 0CDH +TENDWHILE EQU 0CEH +TDATA EQU 0DCH +TDIM EQU 0DEH +TFOR EQU 0E3H +TGOSUB EQU 0E4H +TGOTO EQU 0E5H +TIF EQU 0E7H +TLOCAL EQU 0EAH +TNEXT EQU 0EDH +TON EQU 0EEH +TPROC EQU 0F2H +TREM EQU 0F4H +TREPEAT EQU 0F5H +TRESTORE EQU 0F7H +TTRACE EQU 0FCH +TUNTIL EQU 0FDH +TEXIT EQU 10H +; +TOKLO EQU 8FH +TOKHI EQU 93H +OFFSET EQU 0CFH-TOKLO +; +START: JP COLD + JP WARM + JP ESCAPE + JP EXTERR + JP TELL + JP TEXT + JP ITEMI + JP EXPRI + JP EXPRS + JP OSCLI + JP OSBGET + JP OSBPUT + JP OSSTAT + JP OSSHUT +COLD: LD HL,STAVAR ;COLD START + LD SP,HL + LD (HL),10 + INC L + LD (HL),9 + INC L + XOR A +PURGE: LD (HL),A ;CLEAR SCRATCHPAD + INC L + JR NZ,PURGE + LD A,37H ;V3.0 + LD (LISTON),A + LD HL,NOTICE + LD (ERRTXT),HL + CALL OSINIT + LD (HIMEM),DE + LD (PAGE),HL + CALL NEWIT + JP NZ,CHAIN0 ;AUTO-RUN + CALL TELL +VERMSG: DEFM 'BBC BASIC (Z80) Version 5beta2' + DEFB CR + DEFB LF +NOTICE: DEFM '(C) Copyright R.T.Russell 2024' + DEFB CR + DEFB LF + DEFB 0 +WARM: DEFB 0F6H +CLOOP: SCF + LD SP,(HIMEM) + CALL PROMPT ;PROMPT USER + LD HL,LISTON + LD A,(HL) + AND 0FH ;LISTO + OR 30H ;OPT 3 + LD (HL),A + SBC HL,HL ;HL <- 0 (V3.0) + LD (ERRTRP),HL + LD (ONERSP),HL + LD (CURLIN),HL ;For CMOS EDIT->LIST + LD HL,(AUTONO) + PUSH HL + LD A,H + OR L + JR Z,NOAUTO + PUSH HL + CALL PBCD ;AUTO NUMBER + POP HL + LD BC,(INCREM) + LD B,0 + ADD HL,BC + JP C,TOOBIG + LD (AUTONO),HL + LD A,' ' + CALL OUTCHR +NOAUTO: LD HL,ACCS + CALL OSLINE ;GET CONSOLE INPUT + XOR A + LD (COUNT),A + LD IY,ACCS + LD HL,COMNDS + CALL LEX0 + POP HL + JR NZ,NOTCMD + ADD A,A + LD C,A + LD B,0 + LD HL,CMDTAB + ADD HL,BC + LD A,(HL) ;TABLE ENTRY + INC HL + LD H,(HL) + LD L,A + INC IY + CALL NXT + JP (HL) ;EXECUTE COMMAND +; +NOTCMD: LD A,H + OR L + CALL Z,LINNUM + CALL NXT + LD DE,BUFFER + LD C,1 ;LEFT MODE + PUSH HL + CALL LEXAN2 ;LEXICAL ANALYSIS + POP HL + LD (DE),A ;TERMINATOR + XOR A + LD B,A + LD C,E ;BC=LINE LENGTH + INC DE + LD (DE),A ;ZERO NEXT + LD A,H + OR L + LD IY,BUFFER ;FOR XEQ + JP Z,XEQ ;DIRECT MODE + PUSH BC + CALL FINDL + CALL Z,DEL + POP BC + LD A,C + OR A + JR Z,CLOOP2 ;DELETE LINE ONLY + ADD A,4 + LD C,A ;LENGTH INCLUSIVE + PUSH DE ;LINE NUMBER + PUSH BC ;SAVE LINE LENGTH + EX DE,HL + PUSH BC + CALL GETTOP + POP BC + PUSH HL + ADD HL,BC + PUSH HL + INC H + XOR A + SBC HL,SP + POP HL + JP NC,ERROR ;"No room" + EX (SP),HL + PUSH HL + INC HL + OR A + SBC HL,DE + LD B,H ;BC=AMOUNT TO MOVE + LD C,L + POP HL + POP DE + JR Z,ATEND + LDDR ;MAKE SPACE +ATEND: POP BC ;LINE LENGTH + POP DE ;LINE NUMBER + INC HL + LD (HL),C ;STORE LENGTH + INC HL + LD (HL),E ;STORE LINE NUMBER + INC HL + LD (HL),D + INC HL + LD DE,BUFFER + EX DE,HL + DEC C + DEC C + DEC C + LDIR ;ADD LINE + CALL CLEAN +CLOOP2: JP CLOOP +; +;LIST OF TOKENS AND KEYWORDS. +;IF A KEYWORD IS FOLLOWED BY NUL THEN IT WILL +; ONLY MATCH WITH THE WORD FOLLOWED IMMEDIATELY +; BY A DELIMITER. +; +KEYWDS: DEFB 80H + DEFM 'AND' + DEFB 94H + DEFM 'ABS' + DEFB 95H + DEFM 'ACS' + DEFB 96H + DEFM 'ADVAL' + DEFB 97H + DEFM 'ASC' + DEFB 98H + DEFM 'ASN' + DEFB 99H + DEFM 'ATN' + DEFB 9AH + DEFM 'BGET ' + DEFB 0D5H + DEFM 'BPUT ' + DEFB 0FH + DEFM 'BY ' ; v5 + DEFB 0FBH + DEFM 'COLOUR' + DEFB 0FBH + DEFM 'COLOR' + DEFB 0D6H + DEFM 'CALL' + DEFB 0C8H + DEFM 'CASE' ; v5 + DEFB 0D7H + DEFM 'CHAIN' + DEFB 0BDH + DEFM 'CHR$' + DEFB 01H + DEFM 'CIRCLE' ; v5 + DEFB 0D8H + DEFM 'CLEAR ' + DEFB 0D9H + DEFM 'CLOSE ' + DEFB 0DAH + DEFM 'CLG ' + DEFB 0DBH + DEFM 'CLS ' + DEFB 9BH + DEFM 'COS' + DEFB 9CH + DEFM 'COUNT ' + DEFB 0DCH + DEFM 'DATA' + DEFB 9DH + DEFM 'DEG' + DEFB 0DDH + DEFM 'DEF' + DEFB 81H + DEFM 'DIV' + DEFB 0DEH + DEFM 'DIM' + DEFB 0DFH + DEFM 'DRAW' + DEFB 02H + DEFM 'ELLIPSE' ; v5 + DEFB 0CBH + DEFM 'ENDCASE ' ; v5 + DEFB 0CDH + DEFM 'ENDIF ' ; v5 + DEFB 0E1H + DEFM 'ENDPROC ' + DEFB 0CEH + DEFM 'ENDWHILE ' ; v5 + DEFB 0E0H + DEFM 'END ' + DEFB 0E2H + DEFM 'ENVELOPE' + DEFB 8BH + DEFM 'ELSE' + DEFB 0A0H + DEFM 'EVAL' + DEFB 9EH + DEFM 'ERL ' + DEFB 85H + DEFM 'ERROR' + DEFB 0C5H + DEFM 'EOF ' + DEFB 10H + DEFM 'EXIT ' ; v5 + DEFB 82H + DEFM 'EOR' + DEFB 9FH + DEFM 'ERR ' + DEFB 0A1H + DEFM 'EXP' + DEFB 0A2H + DEFM 'EXT ' + DEFB 0E3H + DEFM 'FOR' + DEFB 0A3H + DEFM 'FALSE ' + DEFB 03H + DEFM 'FILL' ; v5 + DEFB 0A4H + DEFM 'FN' + DEFB 0E5H + DEFM 'GOTO' + DEFB 0BEH + DEFM 'GET$' + DEFB 0A5H + DEFM 'GET' + DEFB 0E4H + DEFM 'GOSUB' + DEFB 0E6H + DEFM 'GCOL' + DEFB 93H + DEFM 'HIMEM ' + DEFB 0E8H + DEFM 'INPUT' + DEFB 0E7H + DEFM 'IF' + DEFB 0BFH + DEFM 'INKEY$' + DEFB 0A6H + DEFM 'INKEY' + DEFB 0CH + DEFM 'INSTALL' ; v5 + DEFB 0A8H + DEFM 'INT' + DEFB 0A7H + DEFM 'INSTR(' + DEFB 86H + DEFM 'LINE' + DEFB 92H + DEFM 'LOMEM ' + DEFB 0EAH + DEFM 'LOCAL' + DEFB 0C0H + DEFM 'LEFT$(' + DEFB 0A9H + DEFM 'LEN' + DEFB 0E9H + DEFM 'LET' + DEFB 0ABH + DEFM 'LOG' + DEFB 0AAH + DEFM 'LN' + DEFB 0C1H + DEFM 'MID$(' + DEFB 0EBH + DEFM 'MODE' + DEFB 83H + DEFM 'MOD' + DEFB 04H + DEFM 'MOUSE' ; v5 + DEFB 0ECH + DEFM 'MOVE' + DEFB 0EDH + DEFM 'NEXT' + DEFB 0ACH + DEFM 'NOT' + DEFB 05H + DEFM 'ORIGIN' ; v5 + DEFB 0CCH + DEFM 'OTHERWISE' ; v5 + DEFB 0EEH + DEFM 'ON' + DEFB 87H + DEFM 'OFF ' + DEFB 0CAH + DEFM 'OF ' ; v5 + DEFB 84H + DEFM 'OR' + DEFB 8EH + DEFM 'OPENIN' + DEFB 0AEH + DEFM 'OPENOUT' + DEFB 0ADH + DEFM 'OPENUP' + DEFB 0FFH + DEFM 'OSCLI' + DEFB 0F1H + DEFM 'PRINT' + DEFB 90H + DEFM 'PAGE ' + DEFB 8FH + DEFM 'PTR ' + DEFB 0AFH + DEFM 'PI ' + DEFB 0F0H + DEFM 'PLOT' + DEFB 0B0H + DEFM 'POINT(' + DEFB 0EH + DEFM 'PUT' ; Token changed + DEFB 0F2H + DEFM 'PROC' + DEFB 0B1H + DEFM 'POS ' + DEFB 06H + DEFM 'QUIT ' ; v5 + DEFB 0F8H + DEFM 'RETURN ' + DEFB 0F5H + DEFM 'REPEAT' + DEFB 0F6H + DEFM 'REPORT ' + DEFB 0F3H + DEFM 'READ' + DEFB 0F4H + DEFM 'REM' + DEFB 0F9H + DEFM 'RUN ' + DEFB 0B2H + DEFM 'RAD' + DEFB 0F7H + DEFM 'RESTORE' + DEFB 0C2H + DEFM 'RIGHT$(' + DEFB 0B3H + DEFM 'RND ' + DEFB 07H + DEFM 'RECTANGLE' ; v5 + DEFB 88H + DEFM 'STEP' + DEFB 0B4H + DEFM 'SGN' + DEFB 0B5H + DEFM 'SIN' + DEFB 0B6H + DEFM 'SQR' + DEFB 89H + DEFM 'SPC' + DEFB 0C3H + DEFM 'STR$' + DEFB 0C4H + DEFM 'STRING$(' + DEFB 0D4H + DEFM 'SOUND' + DEFB 0FAH + DEFM 'STOP ' + DEFB 0C6H + DEFM 'SUM' ; v5 + DEFB 08H + DEFM 'SWAP' ; v5 + DEFB 09H + DEFM 'SYS' ; v5 + DEFB 0B7H + DEFM 'TAN' + DEFB 8CH + DEFM 'THEN' + DEFB 0B8H + DEFM 'TO' + DEFB 8AH + DEFM 'TAB(' + DEFB 0FCH + DEFM 'TRACE' + DEFB 91H + DEFM 'TIME ' + DEFB 0AH + DEFM 'TINT' + DEFB 0B9H + DEFM 'TRUE ' + DEFB 0FDH + DEFM 'UNTIL' + DEFB 0BAH + DEFM 'USR' + DEFB 0EFH + DEFM 'VDU' + DEFB 0BBH + DEFM 'VAL' + DEFB 0BCH + DEFM 'VPOS ' + DEFB 0FEH + DEFM 'WIDTH' + DEFB 0BH + DEFM 'WAIT ' ; v5 + DEFB 0C9H + DEFM 'WHEN' ; v5 + DEFB 0C7H + DEFM 'WHILE' ; v5 +;'LEFT' TOKENS: + DEFB 0CFH + DEFM 'PTR' + DEFB 0D1H + DEFM 'TIME' + DEFB 0D3H + DEFM 'HIMEM' + DEFB 0D2H + DEFM 'LOMEM' + DEFB 0D0H + DEFM 'PAGE' +; + DEFB 11H + DEFM 'Missing ' + DEFB 12H + DEFM 'No such ' + DEFB 13H + DEFM 'Bad ' + DEFB 14H + DEFM ' range' + DEFB 15H + DEFM 'variable' + DEFB 16H + DEFM 'Out of' + DEFB 17H + DEFM 'No ' + DEFB 18H + DEFM ' space' + DEFB 19H + DEFM 'Not in a ' + DEFB 1AH + DEFM ' loop' + DEFB 1BH + DEFM ' not ' +KEYWDL EQU $-KEYWDS + DEFW -1 +; +;LIST OF IMMEDIATE MODE COMMANDS: +; +COMNDS: DEFB 80H + DEFM 'AUTO' + DEFB 81H + DEFM 'DELETE' + DEFB 82H + DEFM 'LIST' + DEFB 83H + DEFM 'LOAD' + DEFB 84H + DEFM 'NEW ' + DEFB 85H + DEFM 'OLD ' + DEFB 86H + DEFM 'RENUMBER' + DEFB 87H + DEFM 'SAVE' + DEFW -1 +; +;IMMEDIATE MODE COMMANDS: +; +CMDTAB: DEFW AUTO + DEFW DELETE + DEFW LIST + DEFW LOAD + DEFW NEW + DEFW OLD + DEFW RENUM + DEFW SAVE +; +;ERROR MESSAGES: +; +ERRWDS: DEFB 17H + DEFM 'room' + DEFB 0 + DEFB 16H + DEFB 14H + DEFW 0 + DEFM 'Multiple label' + DEFB 0 + DEFM 'Mistake' + DEFB 0 + DEFB 11H + DEFM ',' + DEFB 0 + DEFM 'Type mismatch' + DEFB 0 + DEFB 19H + DEFB TFN + DEFW 0 + DEFB 11H + DEFM '"' + DEFB 0 + DEFB 13H + DEFB TDIM + DEFB 0 + DEFB TDIM + DEFB 18H + DEFB 0 + DEFB 19H + DEFB TFN + DEFM ' or ' + DEFB TPROC + DEFB 0 + DEFB 19H + DEFB TPROC + DEFB 0 + DEFB 13H + DEFM 'use of array' + DEFB 0 + DEFB 13H + DEFM 'subscript' + DEFB 0 + DEFM 'Syntax error' + DEFB 0 + DEFM 'Escape' + DEFB 0 + DEFM 'Division by zero' + DEFB 0 + DEFM 'String too long' + DEFB 0 + DEFM 'Number too big' + DEFB 0 + DEFM '-ve root' + DEFB 0 + DEFM 'Log' + DEFB 14H + DEFB 0 + DEFM 'Accuracy lost' + DEFB 0 + DEFM 'Exponent' + DEFB 14H + DEFW 0 + DEFB 12H + DEFB 15H + DEFB 0 + DEFB 11H + DEFM ')' + DEFB 0 + DEFB 13H + DEFM 'hex or binary' + DEFB 0 + DEFB 12H + DEFB TFN + DEFM '/' + DEFB TPROC + DEFB 0 + DEFB 13H + DEFM 'call' + DEFB 0 + DEFB 13H + DEFM 'arguments' + DEFB 0 + DEFB 19H + DEFB TFOR + DEFB 1AH + DEFB 0 + DEFM 'Can''t match ' + DEFB TFOR + DEFB 0 + DEFB 13H + DEFB TFOR + DEFM ' ' + DEFB 15H + DEFW 0 + DEFB 11H + DEFB TTO + DEFW 0 + DEFB 17H + DEFB TGOSUB + DEFB 0 + DEFB TON + DEFM ' syntax' + DEFB 0 + DEFB TON + DEFB 14H + DEFB 0 + DEFB 12H + DEFM 'line' + DEFB 0 + DEFB 16H + DEFM ' ' + DEFB TDATA + DEFB 0 + DEFB 19H + DEFB TREPEAT + DEFB 1AH + DEFB 0 + DEFB 13H + DEFB TEXIT + DEFB 0 + DEFB 11H + DEFM '#' + DEFB 0 + DEFB 19H ;46 Not in a WHILE loop + DEFB TWHILE + DEFB 1AH + DEFB 0 + DEFB 11H ;47 Missing ENDCASE + DEFB TENDCASE + DEFB 0 + DEFB TOF ;48 OF not last + DEFB 1BH + DEFM 'last' + DEFB 0 + DEFB 11H ;49 Missing ENDIF + DEFB TENDIF + DEFB 0 + DEFW 0 + DEFB 0 + DEFB TON ;53 ON ERROR not LOCAL + DEFM ' ' + DEFB TERROR + DEFB 1BH + DEFB TLOCAL + DEFB 0 + DEFB TDATA ;54 DATA not LOCAL + DEFB 1BH + DEFB TLOCAL + DEFB 0 +; +;Indent tokens (first four needn't be at start of line): +; +TOKADD: DEFB TFOR + DEFB TREPEAT + DEFB TWHILE + DEFB TCASE + DEFB TELSE + DEFB TWHEN + DEFB TOTHERWISE +LENADD EQU $-TOKADD +; +;Outdent tokens (first three needn't be at start of line): +; +TOKSUB: DEFB TNEXT + DEFB TUNTIL + DEFB TENDWHILE + DEFB TENDCASE + DEFB TENDIF + DEFB TELSE + DEFB TWHEN + DEFB TOTHERWISE +LENSUB EQU $-TOKSUB +; +;COMMANDS: +; +;DELETE line,line +; +DELETE: CALL DLPAIR +DELET1: LD A,(HL) + OR A + JP Z,WARM + INC HL + LD E,(HL) + INC HL + LD D,(HL) + DEC HL + DEC HL + EX DE,HL + SCF + SBC HL,BC + EX DE,HL + JR NC,WARMNC + PUSH BC + CALL DEL + POP BC + JR DELET1 +; +;LISTO expr +; +LISTO: INC IY ;SKIP "O" + CALL EXPRI + EXX + LD A,L + LD (LISTON),A +CLOOP1: JP CLOOP +; +;LIST +;LIST line +;LIST line,line [IF string] +;LIST ,line +;LIST line, +; +LIST: CP 'O' + JR Z,LISTO + LD C,1 + LD DE,BUFFER + CALL LEXAN2 + LD (DE),A + LD IY,BUFFER + CALL DLPAIR + CALL NXT + CP TIF ;IF CLAUSE ? + LD A,0 ;INIT IF-CLAUSE LENGTH + JR NZ,LISTB + INC IY ;SKIP IF + CALL NXT ;SKIP SPACES (IF ANY) + EX DE,HL + PUSH IY + POP HL ;HL ADDRESSES IF CLAUSE + LD A,CR + PUSH BC + LD BC,256 + CPIR ;LOCATE CR + LD A,C + CPL ;A = SUBSTRING LENGTH + POP BC + EX DE,HL +LISTB: LD E,A ;IF-CLAUSE LENGTH + LD A,B + OR C + JR NZ,LISTA + DEC BC +LISTA: EXX + LD IX,LISTON + LD E,0 ;INDENTATION COUNT + EXX + LD A,20 +; +LISTC: PUSH BC ;SAVE HIGH LINE NUMBER + PUSH DE ;SAVE IF-CLAUSE LENGTH + PUSH HL ;SAVE PROGRAM POINTER + EX AF,AF' + LD A,(HL) + OR A + JR Z,WARMNC +; +;CHECK IF PAST TERMINATING LINE NUMBER: +; + LD A,E ;A = IF-CLAUSE LENGTH + INC HL + LD E,(HL) + INC HL + LD D,(HL) ;DE = LINE NUMBER + DEC HL + DEC HL + PUSH DE ;SAVE LINE NUMBER + EX DE,HL + SCF + SBC HL,BC + EX DE,HL + POP DE ;RESTORE LINE NUMBER +WARMNC: JP NC,WARM + LD C,(HL) ;C = LINE LENGTH + 4 + LD B,A ;B = IF-CLAUSE LENGTH +; +;CHECK FOR IF CLAUSE: +; + INC HL + INC HL + INC HL ;HL ADDRESSES LINE TEXT + DEC C + DEC C + DEC C + DEC C ;C = LINE LENGTH + PUSH DE ;SAVE LINE NUMBER + PUSH HL ;SAVE LINE ADDRESS + XOR A ;A <- 0 + CP B ;WAS THERE AN IF-CLAUSE + PUSH IY + POP DE ;DE ADDRESSES IF-CLAUSE + CALL NZ,SEARCH ;SEARCH FOR IF CLAUSE + POP HL ;RESTORE LINE ADDRESS + POP DE ;RESTORE LINE NUMBER + PUSH IY + CALL Z,LISTIT ;LIST IF MATCH + POP IY +; + EX AF,AF' + DEC A + CALL LTRAP + POP HL ;RESTORE POINTER + LD E,(HL) + LD D,0 + ADD HL,DE ;ADDRESS NEXT LINE + POP DE ;RESTORE IF-CLAUSE LEN + POP BC ;RESTORE HI LINE NUMBER + JR LISTC +; +;RENUMBER +;RENUMBER start +;RENUMBER start,increment +;RENUMBER ,increment +; +RENUM: CALL CLEAR ;USES DYNAMIC AREA + CALL PAIR ;LOAD HL,BC + EXX + LD HL,(PAGE) + LD DE,(LOMEM) +RENUM1: LD A,(HL) ;BUILD TABLE + OR A + JR Z,RENUM2 + INC HL + LD C,(HL) ;OLD LINE NUMBER + INC HL + LD B,(HL) + EX DE,HL + LD (HL),C + INC HL + LD (HL),B + INC HL + EXX + PUSH HL + ADD HL,BC ;ADD INCREMENT + JP C,TOOBIG ;"Too big" + EXX + POP BC + LD (HL),C + INC HL + LD (HL),B + INC HL + EX DE,HL + DEC HL + DEC HL + XOR A + LD B,A + LD C,(HL) + ADD HL,BC ;NEXT LINE + EX DE,HL + PUSH HL + INC H + SBC HL,SP + POP HL + EX DE,HL + JR C,RENUM1 ;CONTINUE + CALL EXTERR ;"Out of space" + DEFB 16H + DEFB 18H + DEFB 0 +; +RENUM2: EX DE,HL + LD (HL),-1 + INC HL + LD (HL),-1 + LD DE,(LOMEM) + EXX + LD HL,(PAGE) +RENUM3: LD C,(HL) + LD A,C + OR A + JP Z,WARM + EXX + EX DE,HL + INC HL + INC HL + LD E,(HL) + INC HL + LD D,(HL) + INC HL + PUSH DE + EX DE,HL + EXX + POP DE + INC HL + LD (HL),E ;NEW LINE NUMBER + INC HL + LD (HL),D + INC HL + DEC C + DEC C + DEC C + LD B,0 +RENUM7: LD A,TLINO + CPIR ;SEARCH FOR LINE NUMBER + JR NZ,RENUM3 + PUSH BC + PUSH HL + PUSH HL + POP IY + EXX + PUSH HL + CALL DECODE ;DECODE LINE NUMBER + POP HL + EXX + LD B,H + LD C,L + LD HL,(LOMEM) +RENUM4: LD E,(HL) ;CROSS-REFERENCE TABLE + INC HL + LD D,(HL) + INC HL + EX DE,HL + OR A ;CLEAR CARRY + SBC HL,BC + EX DE,HL + LD E,(HL) ;NEW NUMBER + INC HL + LD D,(HL) + INC HL + JR C,RENUM4 + EX DE,HL + JR Z,RENUM5 ;FOUND + CALL TELL + DEFM 'Failed at ' + DEFB 0 + EXX + PUSH HL + EXX + POP HL + CALL PBCDL + CALL CRLF + JR RENUM6 +RENUM5: POP DE + PUSH DE + DEC DE + CALL ENCODE ;RE-WRITE NUMBER +RENUM6: POP HL + POP BC + JR RENUM7 +; +;AUTO +;AUTO start,increment +;AUTO start +;AUTO ,increment +; +AUTO: CALL PAIR + LD (AUTONO),HL + LD A,C + LD (INCREM),A + JR CLOOP0 +; +;BAD +;NEW +; +BAD: CALL TELL ;"Bad program' + DEFB 13H + DEFM 'program' + DEFB CR + DEFB LF + DEFB 0 +NEW: CALL NEWIT + JR CLOOP0 +; +;OLD +; +OLD: LD HL,(PAGE) + PUSH HL + INC HL + INC HL + INC HL + LD BC,252 + LD A,CR + CPIR + JR NZ,BAD + LD A,L + POP HL + LD (HL),A + CALL CLEAN +CLOOP0: JP CLOOP +; +;LOAD filename +; +LOAD: CALL EXPRS ;GET FILENAME + LD A,CR + LD (DE),A + CALL LOAD0 + CALL CLEAR + JR WARM0 +; +;SAVE filename +; +SAVE: CALL EXPRS ;FILENAME + LD A,CR + LD (DE),A + LD DE,(PAGE) + CALL GETTOP + OR A + SBC HL,DE + LD B,H ;LENGTH OF PROGRAM + LD C,L + LD HL,ACCS + CALL OSSAVE +WARM0: JP WARM +; +;ERROR +;N.B. CARE NEEDED BECAUSE SP MAY NOT BE VALID (E.G. ABOVE HIMEM) +; +ERROR: LD HL,ERRWDS + LD C,A + OR A + JR Z,ERROR1 + LD B,A ;ERROR NUMBER + XOR A +ERROR0: CP (HL) + INC HL + JR NZ,ERROR0 + DJNZ ERROR0 + JR ERROR1 ;MUST NOT PUSH HL HERE +; +EXTERR: POP HL + LD C,A +ERROR1: LD (ERRTXT),HL + LD HL,(ONERSP) + LD A,H + OR L + LD SP,(HIMEM) ;MUST SET SP BEFORE 'CALL' + JR Z,ERROR4 + LD SP,HL +ERROR4: LD A,C ;ERROR NUMBER + CALL SETLIN ;SP IS SET NOW + LD (ERR),A + LD (ERL),HL + OR A + JR Z,ERROR2 ;'FATAL' ERROR + LD HL,(ERRTRP) + LD A,H + OR L + PUSH HL + POP IY + JP NZ,XEQ ;ERROR TRAPPED +ERROR2: LD SP,(HIMEM) + SBC HL,HL + LD (AUTONO),HL + LD (TRACEN),HL ;CANCEL TRACE + CALL RESET ;RESET OPSYS + CALL CRLF + CALL REPORT ;MESSAGE + LD HL,(ERL) + CALL SAYLN + LD E,0 + CALL C,OSSHUT ;CLOSE ALL FILES + CALL CRLF + JP CLOOP +; +;SUBROUTINES: +; +; +;LEX - SEARCH FOR KEYWORDS +; Inputs: HL = start of keyword table +; IY = start of match text +; Outputs: If found, Z-flag set, A=token. +; If not found, Z-flag reset, A=(IY). +; IY updated (if NZ, IY unchanged). +; Destroys: A,B,H,L,IY,F +; +LEX: LD HL,KEYWDS +LEX0: LD A,(IY) + LD B,(HL) + INC HL + CP (HL) + JR Z,LEX2 + RET C ;FAIL EXIT +LEX1: INC HL + LD A,(HL) + CP 160 + JP PE,LEX1 + JR LEX0 +; +LEX2: PUSH IY ;SAVE POINTER +LEX3: INC HL + LD A,(HL) + CP 160 + JP PO,LEX6 ;FOUND + INC IY + LD A,(IY) + CP (HL) + JR NZ,LEX7 + CP 161 + JP PE,LEX3 +LEX7: LD A,(IY) + CP '.' + JR Z,LEX6 ;FOUND (ABBREV.) + CALL RANGE1 + JR C,LEX5 +LEX4: POP IY ;RESTORE POINTER + JR LEX1 +; +LEX5: LD A,(HL) + CP ' ' + JR NZ,LEX4 + DEC IY +LEX6: POP AF + XOR A + LD A,B + RET +; +;DEL - DELETE A PROGRAM LINE. +; Inputs: HL addresses program line. +; Destroys: B,C,F +; +DEL: PUSH DE + PUSH HL + PUSH HL + LD B,0 + LD C,(HL) + ADD HL,BC + PUSH HL + EX DE,HL + CALL GETTOP + SBC HL,DE + LD B,H + LD C,L + POP HL + POP DE + LDIR ;DELETE LINE + POP HL + POP DE + RET +; +;LOAD0 - LOAD A DISK FILE THEN CLEAN. +; Inputs: Filename in ACCS (term CR) +; Destroys: A,B,C,D,E,H,L,F +; +;CLEAN - CHECK FOR BAD PROGRAM, FIND END OF TEXT +; AND WRITE FF FF. +; Destroys: A,B,C,H,L,F +; +LOAD0: LD DE,(PAGE) + LD HL,-256 + ADD HL,SP + SBC HL,DE ;FIND AVAILABLE SPACE + LD B,H + LD C,L + LD HL,ACCS + CALL OSLOAD ;LOAD + CALL NC,NEWIT + LD A,0 + JP NC,ERROR ;"No room" +CLEAN: CALL GETTOP + DEC HL + LD (HL),-1 ;WRITE &FFFF + DEC HL + LD (HL),-1 + JR CLEAR +; +GETTOP: LD HL,(PAGE) + LD B,0 + LD A,CR +GETOP1: LD C,(HL) + INC C + DEC C + JR Z,GETOP2 + ADD HL,BC + DEC HL + CP (HL) + INC HL + JR Z,GETOP1 + JP BAD +GETOP2: INC HL ;N.B. CALLED FROM NEWIT + INC HL + INC HL + RET +; +;NEWIT - NEW PROGRAM THEN CLEAR +; Destroys: H,L +; +;CLEAR - CLEAR ALL DYNAMIC VARIABLES INCLUDING +; FUNCTION AND PROCEDURE POINTERS. +; Destroys: Nothing +; +NEWIT: LD HL,(PAGE) + LD (HL),0 +CLEAR: PUSH HL + PUSH BC + PUSH AF + CALL GETTOP + LD (LOMEM),HL + LD (FREE),HL + LD HL,DYNVAR + LD B,2*(54+2) +CLEAR1: LD (HL),0 + INC HL + DJNZ CLEAR1 + POP AF + POP BC + POP HL + RET +; +;LISTIT - LIST A PROGRAM LINE. +; Inputs: HL addresses line +; DE = line number (binary) +; E' = indentation count +; IX addresses LISTON +; Destroys: A,D,E,B',C',D',E',H',L',IY,F +; +LISTIT: PUSH HL + EX DE,HL + PUSH BC + CALL PBCD + POP BC + POP HL + LD A,(HL) + EXX + LD HL,TOKSUB + LD BC,LENSUB + CPIR + CALL Z,INDSUB + CP TENDCASE + CALL Z,INDSUB + LD A,' ' + BIT 0,(IX) + CALL NZ,OUTCHR + LD A,E + ADD A,A + BIT 1,(IX) + CALL NZ,SPACES + EXX + LD A,(HL) + LD E,0 + EXX + LD BC,LENADD +LIST5: LD HL,TOKADD + CPIR + CALL Z,INDADD + CP TCASE + CALL Z,INDADD + EXX +LIST8: LD A,(HL) + INC HL + CP CR + JR Z,LIST9 + LD D,A + CP TEXIT + JR NZ,LIST6 + SET 7,E +LIST6: CP '"' + JR NZ,LIST7 + INC E +LIST7: CALL LOUT + LD A,E + AND 81H + JR NZ,LIST8 + LD A,(HL) + EXX + LD HL,TOKSUB + LD BC,3 + CPIR + CALL Z,INDSUB + LD C,4 + JR LIST5 +; +LIST9: LD A,D + CP TTHEN + EXX + CALL Z,INDADD + EXX + JR CRLF +; +PRLINO: PUSH HL + POP IY + PUSH BC + CALL DECODE + POP BC + EXX + PUSH BC + PUSH DE + CALL PBCDL + POP DE + POP BC + EXX + PUSH IY + POP HL + RET +; +LOUT: BIT 0,E + JR NZ,OUTCHR + CP TLINO + JR Z,PRLINO + CALL OUT + RET +; +INDADD: INC E + RET +; +INDSUB: DEC E + JP P,INDRET + INC E +INDRET: RET +; +;CRLF - SEND CARRIAGE RETURN, LINE FEED. +; Destroys: A,F +;OUTCHR - OUTPUT A CHARACTER TO CONSOLE. +; Inputs: A = character +; Destroys: A,F +; +CRLF: LD A,CR + CALL OUTCHR + LD A,LF +OUTCHR: CALL OSWRCH + SUB CR + JR Z,CARRET + RET C ;NON-PRINTING + LD A,(COUNT) + INC A +CARRET: LD (COUNT),A + RET Z + PUSH HL + LD HL,(WIDTH) + CP L + POP HL + RET NZ + JR CRLF +; +;OUT - SEND CHARACTER OR KEYWORD +; Inputs: A = character (>=10, <128) +; A = Token (<10, >=128) +; Destroys: A,F +; +OUT: CP 160 + JP PE,OUTCHR + PUSH BC + PUSH HL + LD HL,KEYWDS + LD BC,KEYWDL + CPIR + CALL NZ,OUTCHR + LD B,160 + CP 145 + JP PE,TOKEN1 + INC B +TOKEN1: LD A,(HL) + INC HL + CP B + PUSH AF + CALL PE,OUTCHR + POP AF + JP PE,TOKEN1 + POP HL + POP BC + RET +; +;FINDL - FIND PROGRAM LINE. +; Inputs: HL = line number (binary) +; Outputs: HL addresses line (if found) +; DE = line number +; Z-flag set if found. +; Destroys: A,B,C,D,E,H,L,F +; +FINDL: EX DE,HL + LD HL,(PAGE) + XOR A ;A=0 + CP (HL) + INC A + RET NC + XOR A ;CLEAR CARRY + LD B,A +FINDL1: LD C,(HL) + PUSH HL + INC HL + LD A,(HL) + INC HL + LD H,(HL) + LD L,A + SBC HL,DE + POP HL + RET NC ;FOUND OR PAST + ADD HL,BC + JR FINDL1 +; +;SETLIN - Search program for line containing address. +; Inputs: Address in (CURLIN) +; Outputs: Line number in HL +; Destroys: B,C,D,E,H,L,F +; +SETLIN: LD B,0 + LD DE,(CURLIN) + LD HL,(PAGE) + OR A + SBC HL,DE + ADD HL,DE + JR NC,SET3 +SET1: LD C,(HL) + INC C + DEC C + JR Z,SET3 + ADD HL,BC + SBC HL,DE + ADD HL,DE + JR C,SET1 + SBC HL,BC + INC HL + LD E,(HL) ;LINE NUMBER + INC HL + LD D,(HL) + EX DE,HL +SET2: RET +; +SET3: LD HL,0 + JR SET2 +; +;SAYLN - PRINT " at line nnnn" MESSAGE. +; Inputs: HL = line number +; Outputs: Carry=0 if line number is zero. +; Carry=1 if line number is non-zero. +; Destroys: A,B,C,D,E,H,L,F +; +SAYLN: LD A,H + OR L + RET Z + CALL TELL + DEFM ' at line ' + DEFB 0 +PBCDL: LD C,0 + JR PBCD0 +; +;PBCD - PRINT NUMBER AS DECIMAL INTEGER. +; Inputs: HL = number (binary). +; Outputs: Carry = 1 +; Destroys: A,B,C,D,E,H,L,F +; +PBCD: LD C,' ' +PBCD0: LD B,5 + LD DE,10000 +PBCD1: XOR A +PBCD2: SBC HL,DE + INC A + JR NC,PBCD2 + ADD HL,DE + DEC A + JR Z,PBCD3 + SET 4,C + SET 5,C +PBCD3: OR C + CALL NZ,OUTCHR + LD A,B + CP 5 + JR Z,PBCD4 + ADD HL,HL + LD D,H + LD E,L + ADD HL,HL + ADD HL,HL + ADD HL,DE +PBCD4: LD DE,1000 + DJNZ PBCD1 + SCF + RET +; +;HANDLE WHOLE ARRAY: +; +GETV1: INC IY + INC IY ;SKIP () + PUSH HL ;SET EXIT CONDITIONS + POP IX + LD A,D + OR 64 ;FLAG ARRAY + CP A + RET +; +;PUTVAR - CREATE VARIABLE AND INITIALISE TO ZERO. +; Inputs: HL, IY as returned from GETVAR (NZ). +; Outputs: As GETVAR. +; Destroys: everything +; +PUTVAR: CALL CREATE + LD A,(IY) + CP '(' + JR NZ,GETVZ ;SET EXIT CONDITIONS + LD A,(IY+1) + CP ')' ;WHOLE ARRAY? + JR Z,GETV1 +ARRAY: LD A,14 ;'Bad use of array' +ERROR3: JP ERROR +; +;GETVAR - GET LOCATION OF VARIABLE, RETURN IN HL & IX +; Inputs: IY addresses first character. +; Outputs: Carry set and NZ if illegal character. +; Z-flag set if variable found, then: +; A = variable type (0,4,5,128 or 129) +; (68,69 or 193 for whole array) +; HL = IX = variable pointer. +; IY updated +; If Z-flag & carry reset, then: +; HL, IY set for subsequent PUTVAR call. +; Destroys: everything +; +GETVAR: LD A,(IY) + CP '!' + JR Z,GETV5 + CP '?' + JR Z,GETV6 + CP '|' + JR Z,GETVF + CP '$' + JR Z,GETV4 + CALL LOCATE + RET NZ + LD A,(IY) + CP '(' ;ARRAY? + JR NZ,GETVX ;EXIT + LD A,(IY+1) + CP ')' ;WHOLE ARRAY? + JR Z,GETV1 + PUSH DE ;SAVE TYPE + LD A,(HL) + INC HL + LD H,(HL) + LD L,A ;INDIRECT LINK + AND 0FEH + OR H + JR Z,ARRAY + LD A,(HL) ;NO. OF DIMENSIONS + OR A + JR Z,ARRAY + INC HL + LD DE,0 ;ACCUMULATOR + PUSH AF + INC IY ;SKIP ( +GETV3: PUSH HL + PUSH DE + CALL EXPRI ;SUBSCRIPT + EXX + POP DE + EX (SP),HL + LD C,(HL) + INC HL + LD B,(HL) + INC HL + EX (SP),HL + EX DE,HL + PUSH DE + CALL MUL16 ;HL=HL*BC + POP DE + ADD HL,DE + EX DE,HL + OR A + SBC HL,BC + LD A,15 + JR NC,ERROR3 ;"Subscript" + POP HL + POP AF + DEC A ;DIMENSION COUNTER + JR NZ,GETV2 + CALL BRAKET ;CLOSING BRACKET + POP AF ;RESTORE TYPE + PUSH HL + CALL X14OR5 ;DE=DE*n + POP HL + ADD HL,DE + LD D,A ;TYPE + LD A,(IY) +GETVX: CP '?' + JR Z,GETV9 + CP '!' + JR Z,GETV8 +GETVZ: PUSH HL ;SET EXIT CONDITIONS + POP IX + LD A,D + CP A + RET +; +GETV2: PUSH AF + CALL COMMA + JR GETV3 +; +;PROCESS UNARY & BINARY INDIRECTION: +; +GETV5: LD A,4 ;UNARY 32-BIT INDIRN. + JR GETV7 +GETV6: XOR A ;UNARY 8-BIT INDIRECTION + JR GETV7 +GETVF: LD A,5 ;VARIANT INDIRECTION + JR GETV7 +GETV4: LD A,128 ;STATIC STRING +GETV7: SBC HL,HL + PUSH AF + JR GETV0 +; +GETV8: LD B,4 ;32-BIT BINARY INDIRN. + JR GETVA +GETV9: LD B,0 ;8-BIT BINARY INDIRN. +GETVA: PUSH HL + POP IX + LD A,D ;TYPE + CP 129 + RET Z ;STRING! + PUSH BC + CALL LOADN ;LEFT OPERAND + CALL SFIX + EXX +GETV0: PUSH HL + INC IY + CALL ITEMI + EXX + POP DE + POP AF + ADD HL,DE + PUSH HL + POP IX + CP A + RET +; +;GETDEF - Find entry for FN or PROC in dynamic area. +; Inputs: IY addresses byte following "DEF" token. +; Outputs: Z flag set if found +; Carry set if neither FN or PROC first. +; If Z: HL points to entry +; IY addresses delimiter +; Destroys: A,D,E,H,L,IY,F +; +GETDEF: LD A,(IY+1) + CALL RANGE1 + RET C + LD A,(IY) + LD HL,FNPTR + CP TFN + JR Z,LOC2 + LD HL,PROPTR + CP TPROC + JR Z,LOC2 + SCF + RET +; +;LOCATE - Try to locate variable name in static or +;dynamic variables. If illegal first character return +;carry, non-zero. If found, return no-carry, zero. +;If not found, return no-carry, non-zero. +; Inputs: IY addresses first character of name. +; A=(IY) +; Outputs: Z-flag set if found, then: +; IY addresses terminator +; HL addresses location of variable +; D=type of variable: 4 = integer +; 5 = floating point +; 129 = string +; Destroys: A,D,E,H,L,IY,F +; +LOCATE: SUB '@' + RET C + LD H,0 + CP 'Z'-'@'+1 + JR NC,LOC0 ;NOT STATIC + ADD A,A + LD L,A + LD A,(IY+1) ;2nd CHARACTER + CP '%' + JR NZ,LOC1 ;NOT STATIC + LD A,(IY+2) + CP '(' + JR Z,LOC1 ;NOT STATIC + ADD HL,HL + LD DE,STAVAR ;STATIC VARIABLES + ADD HL,DE + INC IY + INC IY + LD D,4 ;INTEGER TYPE + XOR A + RET +; +LOC0: CP '_'-'@' + RET C + CP 'z'-'@'+1 + CCF + DEC A ;SET NZ + RET C + SUB 3 + ADD A,A + LD L,A +LOC1: LD DE,DYNVAR ;DYNAMIC VARIABLES + DEC L + DEC L + SCF + RET M + ADD HL,DE +LOC2: LD E,(HL) + INC HL + LD D,(HL) + LD A,D + OR E + JR Z,LOC6 ;UNDEFINED VARIABLE + LD H,D + LD L,E + INC HL ;SKIP LINK + INC HL + PUSH IY +LOC3: LD A,(HL) ;COMPARE + INC HL + INC IY + CP (IY) + JR Z,LOC3 + OR A ;0=TERMINATOR + JR Z,LOC5 ;FOUND (MAYBE) +LOC4: POP IY + EX DE,HL + JR LOC2 ;TRY NEXT ENTRY +; +LOC5: DEC IY + LD A,(IY) + CP '(' + JR Z,LOCX ;FOUND + INC IY + CALL RANGE + JR C,LOCX ;FOUND + CP '(' + JR Z,LOC4 ;KEEP LOOKING + LD A,(IY-1) + CALL RANGE1 + JR NC,LOC4 ;KEEP LOOKING +LOCX: POP DE +TYPE: LD A,(IY-1) + CP '$' + LD D,129 + RET Z ;STRING + CP '&' + LD D,1 + RET Z ;BYTE + CP '%' + LD D,4 + RET Z ;INTEGER + INC D + CP A + RET +; +LOC6: INC A ;SET NZ + RET +; +;CREATE - CREATE NEW ENTRY, INITIALISE TO ZERO. +; Inputs: HL, IY as returned from LOCATE (NZ). +; Outputs: As LOCATE, GETDEF. +; Destroys: As LOCATE, GETDEF. +; +CREATE: XOR A + LD DE,(FREE) + LD (HL),D + DEC HL + LD (HL),E + EX DE,HL + LD (HL),A + INC HL + LD (HL),A + INC HL +LOC7: INC IY + CALL RANGE ;END OF VARIABLE? + JR C,LOC8 + LD (HL),A + INC HL + CALL RANGE1 + JR NC,LOC7 + CP '(' + JR Z,LOC8 + LD A,(IY+1) + CP '(' + JR Z,LOC7 + INC IY +LOC8: LD (HL),0 ;TERMINATOR + INC HL + PUSH HL + CALL TYPE + LD A,(IY) + CP '(' + LD A,2 ;SIZE OF INDIRECT LINK + JR Z,LOC9 + LD A,D + OR A ;STRING? + JP P,LOC9 + LD A,4 +LOC9: LD (HL),0 ;INITIALISE TO ZERO + INC HL + DEC A + JR NZ,LOC9 + LD (FREE),HL + CALL CHECK + POP HL + XOR A + RET +; +;LINNUM - GET LINE NUMBER FROM TEXT STRING +; Inputs: IY = Text Pointer +; Outputs: HL = Line number (zero if none) +; IY updated +; Destroys: A,D,E,H,L,IY,F +; +LINNUM: CALL NXT + LD HL,0 +LINNM1: LD A,(IY) + SUB '0' + RET C + CP 10 + RET NC + INC IY + LD D,H + LD E,L + ADD HL,HL ;*2 + JR C,TOOBIG + ADD HL,HL ;*4 + JR C,TOOBIG + ADD HL,DE ;*5 + JR C,TOOBIG + ADD HL,HL ;*10 + JR C,TOOBIG + LD E,A + LD D,0 + ADD HL,DE ;ADD IN DIGIT + JR NC,LINNM1 +TOOBIG: LD A,20 + JP ERROR ;"Too big" +; +;PAIR - GET PAIR OF LINE NUMBERS FOR RENUMBER/AUTO. +; Inputs: IY = text pointer +; Outputs: HL = first number (10 by default) +; BC = second number (10 by default) +; Destroys: A,B,C,D,E,H,L,B',C',D',E',H',L',IY,F +; +PAIR: CALL LINNUM ;FIRST + LD A,H + OR L + JR NZ,PAIR1 + LD L,10 +PAIR1: CALL TERMQ + INC IY + PUSH HL + LD HL,10 + CALL NZ,LINNUM ;SECOND + EX (SP),HL + POP BC + LD A,B + OR C + RET NZ + CALL EXTERR + DEFM 'Silly' + DEFB 0 +; +;DLPAIR - GET PAIR OF LINE NUMBERS FOR DELETE/LIST. +; Inputs: IY = text pointer +; Outputs: HL = points to program text +; BC = second number (0 by default) +; Destroys: A,B,C,D,E,H,L,IY,F +; +DLPAIR: CALL LINNUM + PUSH HL + CALL TERMQ + JR Z,DLP1 + CP TIF + JR Z,DLP1 + INC IY + CALL LINNUM +DLP1: EX (SP),HL + CALL FINDL + POP BC + RET +; +;TEST FOR VALID CHARACTER IN VARIABLE NAME: +; Inputs: IY addresses character +; Outputs: Carry set if out-of-range. +; Destroys: A,F +; +RANGE: LD A,(IY) + CP '$' + RET Z + CP '%' + RET Z + CP '(' + RET Z + CP '&' + RET Z +RANGE1: CP '0' + RET C + CP '9'+1 + CCF + RET NC + CP '@' ;V2.4 + RET Z +RANGE2: CP 'A' + RET C + CP 'Z'+1 + CCF + RET NC + CP '_' + RET C + CP 'z'+1 + CCF + RET +; +;LEXAN - LEXICAL ANALYSIS. +; Bit 0,C: 1=left, 0=right +; Bit 3,C: 1=in HEX +; Bit 4,C: 1=accept line number +; Bit 5,C: 1=in variable, FN, PROC +; Bit 6,C: 1=in REM, DATA, * +; Bit 7,C: 1=in quotes +; Inputs: IY addresses source string +; DE addresses destination string +; (must be page boundary) +; C sets initial mode +; Outputs: DE, IY updated +; A holds carriage return +; +LEXAN1: LD (DE),A ;TRANSFER TO BUFFER + INC DE ;INCREMENT POINTERS + INC IY +LEXAN2: LD A,E ;MAIN ENTRY + CP 252 ;TEST LENGTH + LD A,19 + JP NC,ERROR ;'String too long' + LD A,(IY) + CP CR + RET Z ;END OF LINE + CALL RANGE1 + JR NC,LEXAN3 + RES 5,C ;NOT IN VARIABLE + RES 3,C ;NOT IN HEX +LEXAN3: CP ' ' + JR Z,LEXAN1 ;PASS SPACES + CP ',' + JR Z,LEXAN1 ;PASS COMMAS + CP 'G' + JR C,LEXAN4 + RES 3,C ;NOT IN HEX +LEXAN4: CP '"' + JR NZ,LEXAN5 + RL C + CCF ;TOGGLE C7 + RR C +LEXAN5: BIT 4,C + JR Z,LEXAN6 + RES 4,C + PUSH BC + PUSH DE + CALL LINNUM ;GET LINE NUMBER + POP DE + POP BC + LD A,H + OR L + CALL NZ,ENCODE ;ENCODE LINE NUMBER + JR LEXAN2 ;CONTINUE +; +LEXAN6: DEC C + JR Z,LEXAN7 ;C=1 (LEFT) + INC C + JR NZ,LEXAN1 + OR A + CALL P,LEX ;TOKENISE IF POSS. + JR LEXAN8 +; +LEXAN7: CP '*' + JR Z,LEXAN9 + OR A + CALL P,LEX ;TOKENISE IF POSS. + CP TOKLO + JR C,LEXAN8 + CP TOKHI+1 + JR NC,LEXAN8 + ADD A,OFFSET ;LEFT VERSION +LEXAN8: CP TREM + JR Z,LEXAN9 + CP TDATA + JR NZ,LEXANA +LEXAN9: SET 6,C ;QUIT TOKENISING +LEXANA: CP TFN + JR Z,LEXANB + CP TPROC + JR Z,LEXANB + CALL RANGE2 + JR C,LEXANC +LEXANB: SET 5,C ;IN VARIABLE/FN/PROC +LEXANC: CP '&' + JR NZ,LEXAND + SET 3,C ;IN HEX +LEXAND: LD HL,LIST1 + PUSH BC + LD BC,LIST1L + CPIR + POP BC + JR NZ,LEXANE + SET 4,C ;ACCEPT LINE NUMBER +LEXANE: LD HL,LIST2 + PUSH BC + LD BC,LIST2L + CPIR + POP BC + JR NZ,LEXANF + SET 0,C ;ENTER LEFT MODE +LEXANF: JP LEXAN1 +; +LIST1: DEFB TGOTO + DEFB TGOSUB + DEFB TRESTORE + DEFB TTRACE +LIST2: DEFB TTHEN + DEFB TELSE +LIST1L EQU $-LIST1 + DEFB TREPEAT + DEFB TERROR + DEFB ':' +LIST2L EQU $-LIST2 +; +;ENCODE - ENCODE LINE NUMBER INTO PSEUDO-BINARY FORM. +; Inputs: HL=line number, DE=string pointer +; Outputs: DE updated, BIT 4,C set. +; Destroys: A,B,C,D,E,H,L,F +; +ENCODE: SET 4,C + EX DE,HL + LD (HL),TLINO + INC HL + LD A,D + AND 0C0H + RRCA + RRCA + LD B,A + LD A,E + AND 0C0H + OR B + RRCA + RRCA + XOR 01010100B + LD (HL),A + INC HL + LD A,E + AND 3FH + OR '@' + LD (HL),A + INC HL + LD A,D + AND 3FH + OR '@' + LD (HL),A + INC HL + EX DE,HL + RET +; +;TEXT - OUTPUT MESSAGE. +; Inputs: HL addresses text (terminated by nul) +; Outputs: HL addresses character following nul. +; Destroys: A,H,L,F +; +REPORT: LD HL,(ERRTXT) +TEXT: LD A,(HL) + INC HL + OR A + RET Z + CP LF + JR Z,TEXTLF ;Token for TINT + CALL OUT + JR TEXT +; +TEXTLF: CALL OUTCHR + JR TEXT +; +;TELL - OUTPUT MESSAGE. +; Inputs: Text follows subroutine call (term=nul) +; Destroys: A,F +; +TELL: EX (SP),HL ;GET RETURN ADDRESS + CALL TEXT + EX (SP),HL + RET +; +; NLIST - Check for end of list +; +NLIST: CALL NXT + CP ',' ;ANOTHER VARIABLE? + JR Z,NXT1 + POP BC ;DITCH RETURN ADDRESS + JP XEQ +; +NXT: LD A,(IY) + CP ' ' + RET NZ +NXT1: INC IY + JR NXT +; + END START diff --git a/src/MATH.Z80 b/src/MATH.Z80 new file mode 100644 index 0000000..1d4e864 --- /dev/null +++ b/src/MATH.Z80 @@ -0,0 +1,2266 @@ + TITLE '(C) COPYRIGHT R.T.RUSSELL 1986-2024' +; +;Z80 FLOATING POINT PACKAGE +;(C) COPYRIGHT R.T.RUSSELL 1986-2024 +;VERSION 0.0, 26-10-1986 +;VERSION 0.1, 14-12-1988 (BUG FIX) +;VERSION 5.0, 21-05-2024 (SHIFTS ADDED) +; +;BINARY FLOATING POINT REPRESENTATION: +; 32 BIT SIGN-MAGNITUDE NORMALIZED MANTISSA +; 8 BIT EXCESS-128 SIGNED EXPONENT +; SIGN BIT REPLACES MANTISSA MSB (IMPLIED "1") +; MANTISSA=0 & EXPONENT=0 IMPLIES VALUE IS ZERO. +; +;BINARY INTEGER REPRESENTATION: +; 32 BIT 2'S-COMPLEMENT SIGNED INTEGER +; "EXPONENT" BYTE = 0 (WHEN PRESENT) +; +;NORMAL REGISTER ALLOCATION: MANTISSA - HLH'L' +; EXPONENT - C +;ALTERNATE REGISTER ALLOCATION: MANTISSA - DED'E' +; EXPONENT - B +; +;Error codes: +; +BADOP EQU 1 ;Bad operation code +DIVBY0 EQU 18 ;Division by zero +TOOBIG EQU 20 ;Too big +NGROOT EQU 21 ;Negative root +LOGRNG EQU 22 ;Log range +ACLOST EQU 23 ;Accuracy lost +EXPRNG EQU 24 ;Exp range +; + GLOBAL FPP + EXTRN STORE5 + EXTRN DLOAD5 +; +;Call entry and despatch code: +; +FPP: PUSH IY ;Save IY + LD IY,0 + ADD IY,SP ;Save SP in IY + CALL OP ;Perform operation + CP A ;Good return (Z, NC) +EXIT: POP IY ;Restore IY + RET ;Return to caller +; +;Error exit: +; +BAD: LD A,BADOP ;"Bad operation code" +ERROR: LD SP,IY ;Restore SP from IY + OR A ;Set NZ + SCF ;Set C + JR EXIT +; +;Perform operation or function: +; +OP: CP (RTABLE-DTABLE)/2 + JR NC,BAD + CP (FTABLE-DTABLE)/2 + JR NC,DISPAT + EX AF,AF' + LD A,B + OR C ;Both integer? + CALL NZ,FLOATA ;No, so float both + EX AF,AF' +DISPAT: PUSH HL + LD HL,DTABLE + PUSH BC + ADD A,A ;A = op-code * 2 + LD C,A + LD B,0 ;BC = op-code * 2 + ADD HL,BC + LD A,(HL) ;Get low byte + INC HL + LD H,(HL) ;Get high byte + LD L,A + POP BC + EX (SP),HL + RET ;Off to routine +; +;Despatch table: +; +DTABLE: DEFW IAND ;0 AND (INTEGER) + DEFW IBDIV ;1 DIV + DEFW IEOR ;2 EOR + DEFW IMOD ;3 MOD + DEFW IOR ;4 OR + DEFW ILE ;5 <= + DEFW INE ;6 <> + DEFW IGE ;7 >= + DEFW ILT ;8 < + DEFW IEQ ;9 = + DEFW IMUL ;10 * + DEFW IADD ;11 + + DEFW IGT ;12 > + DEFW ISUB ;13 - + DEFW IPOW ;14 ^ + DEFW IDIV ;15 / +; +FTABLE: DEFW ABS ;16 ABS + DEFW ACS ;17 ACS + DEFW ASN ;18 ASN + DEFW ATN ;19 ATN + DEFW COS ;20 COS + DEFW DEG ;21 DEG + DEFW EXP ;22 EXP + DEFW INT ;23 INT + DEFW LN ;24 LN + DEFW LOG ;25 LOG + DEFW CPL ;26 NOT + DEFW RAD ;27 RAD + DEFW SGN ;28 SGN + DEFW SIN ;29 SIN + DEFW SQR ;30 SQR + DEFW TAN ;31 TAN +; + DEFW ZERO ;32 ZERO + DEFW FONE ;33 FONE + DEFW TRUE ;34 TRUE + DEFW PI ;35 PI +; + DEFW VAL ;36 VAL + DEFW STR ;37 STR$ +; + DEFW SFIX ;38 FIX + DEFW SFLOAT ;39 FLOAT +; + DEFW FTEST ;40 TEST + DEFW FCOMP ;41 COMPARE +; + DEFW ISHL ;42 << + DEFW ISHX ;43 <<< + DEFW ISAR ;44 >> + DEFW ISHR ;45 >>> +; +RTABLE: DEFW FAND ;AND (FLOATING-POINT) + DEFW FBDIV ;DIV + DEFW FEOR ;EOR + DEFW FMOD ;MOD + DEFW FOR ;OR + DEFW FLE ;<= + DEFW FNE ;<> + DEFW FGE ;>= + DEFW FLT ;< + DEFW FEQ ;= + DEFW FMUL ;* + DEFW FADD ;+ + DEFW FGT ;> + DEFW FSUB ;- + DEFW FPOW ;^ + DEFW FDIV ;/ +; +;ARITHMETIC AND LOGICAL OPERATORS: +;All take two arguments, in HLH'L'C & DED'E'B. +;Output in HLH'L'C +;All registers except IX, IY destroyed. +; (N.B. FPOW destroys IX). +; +;FAND - Floating-point AND. +;IAND - Integer AND. +; +FAND: CALL FIX2 +IAND: LD A,H + AND D + LD H,A + LD A,L + AND E + LD L,A + EXX + LD A,H + AND D + LD H,A + LD A,L + AND E + LD L,A + EXX + RET +; +;FEOR - Floating-point exclusive-OR. +;IEOR - Integer exclusive-OR. +; +FEOR: CALL FIX2 +IEOR: LD A,H + XOR D + LD H,A + LD A,L + XOR E + LD L,A + EXX + LD A,H + XOR D + LD H,A + LD A,L + XOR E + LD L,A + EXX + RET +; +;FOR - Floating-point OR. +;IOR - Integer OR. +; +FOR: CALL FIX2 +IOR: LD A,H + OR D + LD H,A + LD A,L + OR E + LD L,A + EXX + LD A,H + OR D + LD H,A + LD A,L + OR E + LD L,A + EXX + RET +; +;FMOD - Floating-point remainder. +;IMOD - Integer remainder. +; +FMOD: CALL FIX2 +IMOD: LD A,H + XOR D ;DIV RESULT SIGN + BIT 7,H + CALL ABS2 ;MAKE BOTH POSITIVE + LD A,-33 + CALL DIVA ;DIVIDE + EXX + LD C,0 ;INTEGER MARKER + EX AF,AF' + RET Z + JP NEGATE +; +;BDIV - Integer division. +; +FBDIV: CALL FIX2 +IBDIV: CALL IMOD + OR A + CALL SWAP + LD C,0 + RET P + JP NEGATE +; +;ISUB - Integer subtraction. +;FSUB - Floating point subtraction with rounding. +; +ISUB: CALL SUB + RET PO + CALL ADD + CALL FLOAT2 +FSUB: LD A,D + XOR 80H ;CHANGE SIGN THEN ADD + LD D,A + JR FADD +; +;Reverse subtract. +; +RSUB: LD A,H + XOR 80H + LD H,A + JR FADD +; +;IADD - Integer addition. +;FADD - Floating point addition with rounding. +; +IADD: CALL ADD + RET PO + CALL SUB + CALL FLOAT2 +FADD: DEC B + INC B + RET Z ;ARG 2 ZERO + DEC C + INC C + JP Z,SWAP ;ARG 1 ZERO + EXX + LD BC,0 ;INITIALISE + EXX + LD A,H + XOR D ;XOR SIGNS + PUSH AF + LD A,B + CP C ;COMPARE EXPONENTS + CALL C,SWAP ;MAKE DED'E'B LARGEST + LD A,B + SET 7,H ;IMPLIED 1 + CALL NZ,FIX ;ALIGN + POP AF + LD A,D ;SIGN OF LARGER + SET 7,D ;IMPLIED 1 + JP M,FADD3 ;SIGNS DIFFERENT + CALL ADD ;HLH'L'=HLH'L'+DED'E' + CALL C,DIV2 ;NORMALISE + SET 7,H + JR FADD4 +; +FADD3: CALL SUB ;HLH'L'=HLH'L'-DED'E' + CALL C,NEG ;NEGATE HLH'L'B'C' + CALL FLO48 + CPL ;CHANGE RESULT SIGN +FADD4: EXX + EX DE,HL + LD HL,8000H + OR A ;CLEAR CARRY + SBC HL,BC + EX DE,HL + EXX + CALL Z,ODD ;ROUND UNBIASSED + CALL C,ADD1 ;ROUND UP + CALL C,INCC + RES 7,H + DEC C + INC C + JP Z,ZERO + OR A ;RESULT SIGNQ + RET P ;POSITIVE + SET 7,H ;NEGATIVE + RET +; +;IDIV - Integer division. +;FDIV - Floating point division with rounding. +; +IDIV: CALL FLOAT2 +FDIV: DEC B ;TEST FOR ZERO + INC B + LD A,DIVBY0 + JP Z,ERROR ;"Division by zero" + DEC C ;TEST FOR ZERO + INC C + RET Z + LD A,H + XOR D ;CALC. RESULT SIGN + EX AF,AF' ;SAVE SIGN + SET 7,D ;REPLACE IMPLIED 1's + SET 7,H + PUSH BC ;SAVE EXPONENTS + LD B,D ;LOAD REGISTERS + LD C,E + LD DE,0 + EXX + LD B,D + LD C,E + LD DE,0 + LD A,-32 ;LOOP COUNTER + CALL DIVA ;DIVIDE + EXX + BIT 7,D + EXX + CALL Z,DIVB ;NORMALISE & INC A + EX DE,HL + EXX + SRL B ;DIVISOR/2 + RR C + OR A ;CLEAR CARRY + SBC HL,BC ;REMAINDER-DIVISOR/2 + CCF + EX DE,HL ;RESULT IN HLH'L' + CALL Z,ODD ;ROUND UNBIASSED + CALL C,ADD1 ;ROUND UP + POP BC ;RESTORE EXPONENTS + CALL C,INCC + RRA ;LSB OF A TO CARRY + LD A,C ;COMPUTE NEW EXPONENT + SBC A,B + CCF + JP CHKOVF +; +;IMUL - Integer multiplication. +; +IMUL: LD A,H + XOR D + CALL ABS2 ;MAKE BOTH POSITIVE + LD A,-33 + CALL MULA ;MULTIPLY + EXX + LD C,191 ;PRESET EXPONENT + CALL TEST ;TEST RANGE + JR NZ,IMUL1 ;TOO BIG + BIT 7,D + JR NZ,IMUL1 + CALL SWAP + LD C,D ;INTEGER MARKER + EX AF,AF' + RET P + JP NEGATE +; +IMUL1: DEC C + EXX + SLA E + RL D + EXX + RL E + RL D + EXX + ADC HL,HL + EXX + ADC HL,HL + JP P,IMUL1 ;NORMALISE + EX AF,AF' + RET M + RES 7,H ;POSITIVE + RET +; +;FMUL - Floating point multiplication with rounding. +; +FMUL: DEC B ;TEST FOR ZERO + INC B + JP Z,ZERO + DEC C ;TEST FOR ZERO + INC C + RET Z + LD A,H + XOR D ;CALC. RESULT SIGN + EX AF,AF' + SET 7,D ;REPLACE IMPLIED 1's + SET 7,H + PUSH BC ;SAVE EXPONENTS + LD B,H ;LOAD REGISTERS + LD C,L + LD HL,0 + EXX + LD B,H + LD C,L + LD HL,0 + LD A,-32 ;LOOP COUNTER + CALL MULA ;MULTIPLY + CALL C,MULB ;NORMALISE & INC A + EXX + PUSH HL + LD HL,8000H + OR A ;CLEAR CARRY + SBC HL,DE + POP HL + CALL Z,ODD ;ROUND UNBIASSED + CALL C,ADD1 ;ROUND UP + POP BC ;RESTORE EXPONENTS + CALL C,INCC + RRA ;LSB OF A TO CARRY + LD A,C ;COMPUTE NEW EXPONENT + ADC A,B +CHKOVF: JR C,CHKO1 + JP P,ZERO ;UNDERFLOW + JR CHKO2 +CHKO1: JP M,OFLOW ;OVERFLOW +CHKO2: ADD A,80H + LD C,A + JP Z,ZERO + EX AF,AF' ;RESTORE SIGN BIT + RES 7,H + RET P + SET 7,H + RET +; +;IPOW - Integer involution. +; +IPOW: CALL SWAP + BIT 7,H + PUSH AF ;SAVE SIGN + CALL NZ,NEGATE +IPOW0: LD C,B + LD B,32 ;LOOP COUNTER +IPOW1: CALL X2 + JR C,IPOW2 + DJNZ IPOW1 + POP AF + EXX + INC L ;RESULT=1 + EXX + LD C,H + RET +; +IPOW2: POP AF + PUSH BC + EX DE,HL + PUSH HL + EXX + EX DE,HL + PUSH HL + EXX + LD IX,0 + ADD IX,SP + JR Z,IPOW4 + PUSH BC + EXX + PUSH DE + EXX + PUSH DE + CALL SFLOAT + CALL RECIP + CALL STORE5 + JR IPOW5 +; +IPOW3: PUSH BC + EXX + SLA E + RL D + PUSH DE + EXX + RL E + RL D + PUSH DE + LD A,'*' AND 0FH + PUSH AF + CALL COPY + CALL OP ;SQUARE + POP AF + CALL DLOAD5 + CALL C,OP ;MULTIPLY BY X +IPOW5: POP DE + EXX + POP DE + EXX + LD A,C + POP BC + LD C,A +IPOW4: DJNZ IPOW3 + POP AF + POP AF + POP AF + RET +; +FPOW0: POP AF + POP AF + POP AF + JR IPOW0 +; +;FPOW - Floating-point involution. +; +FPOW: BIT 7,D + PUSH AF + CALL SWAP + CALL PUSH5 + DEC C + INC C + JR Z,FPOW0 + LD A,158 + CP C + JR C,FPOW1 + INC A + CALL FIX + EX AF,AF' + JP P,FPOW0 +FPOW1: CALL SWAP + CALL LN0 + CALL POP5 + POP AF + CALL FMUL + JP EXP0 +; +;Integer and floating-point compare. +;Result is TRUE (-1) or FALSE (0). +; +FLT: CALL FCP + JR ILT1 +ILT: CALL ICP +ILT1: RET NC + JR TRUE +; +FGT: CALL FCP + JR IGT1 +IGT: CALL ICP +IGT1: RET Z + RET C + JR TRUE +; +FGE: CALL FCP + JR IGE1 +IGE: CALL ICP +IGE1: RET C + JR TRUE +; +FLE: CALL FCP + JR ILE1 +ILE: CALL ICP +ILE1: JR Z,TRUE + RET NC + JR TRUE +; +FNE: CALL FCP + JR INE1 +INE: CALL ICP +INE1: RET Z + JR TRUE +; +FEQ: CALL FCP + JR IEQ1 +IEQ: CALL ICP +IEQ1: RET NZ +TRUE: LD HL,-1 + EXX + LD HL,-1 + EXX + XOR A + LD C,A + RET +; +;Integer shifts: +; +ISHX: +ISHL: CALL SHIFTS + JR Z,SHRET +ISHL1: EXX + ADD HL,HL + EXX + ADC HL,HL + DJNZ ISHL1 +SHRET: RET +; +ISAR: CALL SHIFTS + JR Z,SHRET +ISAR1: SRA H + RR L + EXX + RR H + RR L + EXX + DJNZ ISAR1 + RET +; +ISHR: CALL SHIFTS + JR Z,SHRET +ISHR1: SRL H + RR L + EXX + RR H + RR L + EXX + DJNZ ISHR1 + RET +; +SHIFTS: CALL FIX2 + LD A,D + OR E + EXX + OR D + LD A,E + EXX + LD B,32 + JR NZ,SHMAX + LD B,A + OR A +SHMAX: RET +; +;FUNCTIONS: +; +;Result returned in HLH'L'C (floating point) +;Result returned in HLH'L' (C=0) (integer) +;All registers except IY destroyed. +; +;ABS - Absolute value +;Result is numeric, variable type. +; +ABS: BIT 7,H + RET Z ;POSITIVE/ZERO + DEC C + INC C + JP Z,NEGATE ;INTEGER + RES 7,H + RET +; +;NOT - Complement integer. +;Result is integer numeric. +; +CPL: CALL SFIX + LD A,H + CPL + LD H,A + LD A,L + CPL + LD L,A + EXX + LD A,H + CPL + LD H,A + LD A,L + CPL + LD L,A + EXX + XOR A ;NUMERIC MARKER + RET +; +;PI - Return PI (3.141592654) +;Result is floating-point numeric. +; +PI: LD HL,490FH + EXX + LD HL,0DAA2H + EXX + LD C,81H + XOR A ;NUMERIC MARKER + RET +; +;DEG - Convert radians to degrees +;Result is floating-point numeric. +; +DEG: CALL FPI180 + CALL FMUL + XOR A + RET +; +;RAD - Convert degrees to radians +;Result is floating-point numeric. +; +RAD: CALL FPI180 + CALL FDIV + XOR A + RET +; +;180/PI +; +FPI180: CALL SFLOAT + LD DE,652EH + EXX + LD DE,0E0D3H + EXX + LD B,85H + RET +; +;SGN - Return -1, 0 or +1 +;Result is integer numeric. +; +SGN: CALL TEST + OR C + RET Z ;ZERO + BIT 7,H + JP NZ,TRUE ;-1 + CALL ZERO + JP ADD1 ;1 +; +;VAL - Return numeric value of string. +;Input: ASCII string at IX +;Result is variable type numeric. +; +VAL: CALL SIGNQ + PUSH AF + CALL CON + POP AF + CP '-' + LD A,0 ;NUMERIC MARKER + RET NZ + DEC C + INC C + JP Z,NEGATE ;ZERO/INTEGER + LD A,H + XOR 80H ;CHANGE SIGN (FP) + LD H,A + XOR A + RET +; +;INT - Floor function +;Result is integer numeric. +; +INT: DEC C + INC C + RET Z ;ZERO/INTEGER + LD A,159 + LD B,H ;B7=SIGN BIT + CALL FIX + EX AF,AF' + AND B + CALL M,ADD1 ;NEGATIVE NON-INTEGER + LD A,B + OR A + CALL M,NEGATE + XOR A + LD C,A + RET +; +;SQR - square root +;Result is floating-point numeric. +; +SQR: CALL SFLOAT +SQR0: BIT 7,H + LD A,NGROOT + JP NZ,ERROR ;"-ve root" + DEC C + INC C + RET Z ;ZERO + SET 7,H ;IMPLIED 1 + BIT 0,C + CALL Z,DIV2 ;MAKE EXPONENT ODD + LD A,C + SUB 80H + SRA A ;HALVE EXPONENT + ADD A,80H + LD C,A + PUSH BC ;SAVE EXPONENT + EX DE,HL + LD HL,0 + LD B,H + LD C,L + EXX + EX DE,HL + LD HL,0 + LD B,H + LD C,L + LD A,-31 + CALL SQRA ;ROOT + EXX + BIT 7,B + EXX + CALL Z,SQRA ;NORMALISE & INC A + CALL SQRB + OR A ;CLEAR CARRY + CALL DIVB + RR E ;LSB TO CARRY + LD H,B + LD L,C + EXX + LD H,B + LD L,C + CALL C,ADD1 ;ROUND UP + POP BC ;RESTORE EXPONENT + CALL C,INCC + RRA + SBC A,A + ADD A,C + LD C,A + RES 7,H ;POSITIVE + XOR A + RET +; +;TAN - Tangent function +;Result is floating-point numeric. +; +TAN: CALL SFLOAT + CALL PUSH5 + CALL COS0 + CALL POP5 + CALL PUSH5 + CALL SWAP + CALL SIN0 + CALL POP5 + CALL FDIV + XOR A ;NUMERIC MARKER + RET +; +;COS - Cosine function +;Result is floating-point numeric. +; +COS: CALL SFLOAT +COS0: CALL SCALE + INC E + INC E + LD A,E + JR SIN1 +; +;SIN - Sine function +;Result is floating-point numeric. +; +SIN: CALL SFLOAT +SIN0: PUSH HL ;H7=SIGN + CALL SCALE + POP AF + RLCA + RLCA + RLCA + AND 4 + XOR E +SIN1: PUSH AF ;OCTANT + RES 7,H + RRA + CALL PIBY4 + CALL C,RSUB ;X=(PI/4)-X + POP AF + PUSH AF + AND 3 + JP PO,SIN2 ;USE COSINE APPROX. + CALL PUSH5 ;SAVE X + CALL SQUARE ;PUSH X*X + CALL POLY + DEFW 0A8B7H ;a(8) + DEFW 3611H + DEFB 6DH + DEFW 0DE26H ;a(6) + DEFW 0D005H + DEFB 73H + DEFW 80C0H ;a(4) + DEFW 888H + DEFB 79H + DEFW 0AA9DH ;a(2) + DEFW 0AAAAH + DEFB 7DH + DEFW 0 ;a(0) + DEFW 0 + DEFB 80H + CALL POP5 + CALL POP5 + CALL FMUL + JP SIN3 +; +SIN2: CALL SQUARE ;PUSH X*X + CALL POLY + DEFW 0D571H ;b(8) + DEFW 4C78H + DEFB 70H + DEFW 94AFH ;b(6) + DEFW 0B603H + DEFB 76H + DEFW 9CC8H ;b(4) + DEFW 2AAAH + DEFB 7BH + DEFW 0FFDDH ;b(2) + DEFW 0FFFFH + DEFB 7EH + DEFW 0 ;b(0) + DEFW 0 + DEFB 80H + CALL POP5 +SIN3: POP AF + AND 4 + RET Z + DEC C + INC C + RET Z ;ZERO + SET 7,H ;MAKE NEGATIVE + RET +; +;Floating-point one: +; +FONE: LD HL,0 + EXX + LD HL,0 + EXX + LD C,80H + RET +; +DONE: LD DE,0 + EXX + LD DE,0 + EXX + LD B,80H + RET +; +PIBY4: LD DE,490FH + EXX + LD DE,0DAA2H + EXX + LD B,7FH + RET +; +;EXP - Exponential function +;Result is floating-point numeric. +; +EXP: CALL SFLOAT +EXP0: CALL LN2 ;LN(2) + EXX + DEC E + LD BC,0D1CFH ;0.6931471805599453 + EXX + PUSH HL ;H7=SIGN + CALL MOD48 ;"MODULUS" + POP AF + BIT 7,E + JR Z,EXP1 + RLA + JP C,ZERO + LD A,EXPRNG + JP ERROR ;"Exp range" +; +EXP1: AND 80H + OR E + PUSH AF ;INTEGER PART + RES 7,H + CALL PUSH5 ;PUSH X*LN(2) + CALL POLY + DEFW 4072H ;a(7) + DEFW 942EH + DEFB 73H + DEFW 6F65H ;a(6) + DEFW 2E4FH + DEFB 76H + DEFW 6D37H ;a(5) + DEFW 8802H + DEFB 79H + DEFW 0E512H ;a(4) + DEFW 2AA0H + DEFB 7BH + DEFW 4F14H ;a(3) + DEFW 0AAAAH + DEFB 7DH + DEFW 0FD56H ;a(2) + DEFW 7FFFH + DEFB 7EH + DEFW 0FFFEH ;a(1) + DEFW 0FFFFH + DEFB 7FH + DEFW 0 ;a(0) + DEFW 0 + DEFB 80H + CALL POP5 + POP AF + PUSH AF + CALL P,RECIP ;X=1/X + POP AF + JP P,EXP4 + AND 7FH + NEG +EXP4: ADD A,80H + ADD A,C + JR C,EXP2 + JP P,ZERO ;UNDERFLOW + JR EXP3 +EXP2: JP M,OFLOW ;OVERFLOW +EXP3: ADD A,80H + JP Z,ZERO + LD C,A + XOR A ;NUMERIC MARKER + RET +; +RECIP: CALL DONE +RDIV: CALL SWAP + JP FDIV ;RECIPROCAL +; +LN2: LD DE,3172H ;LN(2) + EXX + LD DE,17F8H + EXX + LD B,7FH + RET +; +;LN - Natural log. +;Result is floating-point numeric. +; +LN: CALL SFLOAT +LN0: LD A,LOGRNG + BIT 7,H + JP NZ,ERROR ;"Log range" + INC C + DEC C + JP Z,ERROR + LD DE,3504H ;SQR(2) + EXX + LD DE,0F333H ;1.41421356237 + EXX + CALL ICP0 ;MANTISSA>SQR(2)? + LD A,C ;EXPONENT + LD C,80H ;1 <= X < 2 + JR C,LN4 + DEC C + INC A +LN4: PUSH AF ;SAVE EXPONENT + CALL RATIO ;X=(X-1)/(X+1) + CALL PUSH5 + CALL SQUARE ;PUSH X*X + CALL POLY + DEFW 0CC48H ;a(9) + DEFW 74FBH + DEFB 7DH + DEFW 0AEAFH ;a(7) + DEFW 11FFH + DEFB 7EH + DEFW 0D98CH ;a(5) + DEFW 4CCDH + DEFB 7EH + DEFW 0A9E3H ;a(3) + DEFW 2AAAH + DEFB 7FH + DEFW 0 ;a(1) + DEFW 0 + DEFB 81H + CALL POP5 + CALL POP5 + CALL FMUL + POP AF ;EXPONENT + CALL PUSH5 + EX AF,AF' + CALL ZERO + EX AF,AF' + SUB 80H + JR Z,LN3 + JR NC,LN1 + CPL + INC A +LN1: LD H,A + LD C,87H + PUSH AF + CALL FLOAT + RES 7,H + CALL LN2 + CALL FMUL + POP AF + JR NC,LN3 + JP M,LN3 + SET 7,H +LN3: CALL POP5 + CALL FADD + XOR A + RET +; +;LOG - base-10 logarithm. +;Result is floating-point numeric. +; +LOG: CALL LN + LD DE,5E5BH ;LOG(e) + EXX + LD DE,0D8A9H + EXX + LD B,7EH + CALL FMUL + XOR A + RET +; +;ASN - Arc-sine +;Result is floating-point numeric. +; +ASN: CALL SFLOAT + CALL PUSH5 + CALL COPY + CALL FMUL + CALL DONE + CALL RSUB + CALL SQR0 + CALL POP5 + INC C + DEC C + LD A,2 + PUSH DE + JR Z,ACS1 + POP DE + CALL RDIV + JR ATN0 +; +;ATN - arc-tangent +;Result is floating-point numeric. +; +ATN: CALL SFLOAT +ATN0: PUSH HL ;SAVE SIGN + RES 7,H + LD DE,5413H ;TAN(PI/8)=SQR(2)-1 + EXX + LD DE,0CCD0H + EXX + LD B,7EH + CALL FCP0 ;COMPARE + LD B,0 + JR C,ATN2 + LD DE,1A82H ;TAN(3*PI/8)=SQR(2)+1 + EXX + LD DE,799AH + EXX + LD B,81H + CALL FCP0 ;COMPARE + JR C,ATN1 + CALL RECIP ;X=1/X + LD B,2 + JP ATN2 +ATN1: CALL RATIO ;X=(X-1)/(X+1) + LD B,1 +ATN2: PUSH BC ;SAVE FLAG + CALL PUSH5 + CALL SQUARE ;PUSH X*X + CALL POLY + DEFW 0F335H ;a(13) + DEFW 37D8H + DEFB 7BH + DEFW 6B91H ;a(11) + DEFW 0AAB9H + DEFB 7CH + DEFW 41DEH ;a(9) + DEFW 6197H + DEFB 7CH + DEFW 9D7BH ;a(7) + DEFW 9237H + DEFB 7DH + DEFW 2A5AH ;a(5) + DEFW 4CCCH + DEFB 7DH + DEFW 0A95CH ;a(3) + DEFW 0AAAAH + DEFB 7EH + DEFW 0 ;a(1) + DEFW 0 + DEFB 80H + CALL POP5 + CALL POP5 + CALL FMUL + POP AF +ACS1: CALL PIBY4 ;PI/4 + RRA + PUSH AF + CALL C,FADD + POP AF + INC B + RRA + CALL C,RSUB + POP AF + OR A + RET P + SET 7,H ;MAKE NEGATIVE + XOR A + RET +; +;ACS - Arc cosine=PI/2-ASN. +;Result is floating point numeric. +; +ACS: CALL ASN + LD A,2 + PUSH AF + JR ACS1 +; +;Function STR - convert numeric value to ASCII string. +; Inputs: HLH'L'C = integer or floating-point number +; DE = address at which to store string +; IX = address of @% format control +; Outputs: String stored, with NUL terminator +; +;First normalise for decimal output: +; +STR: CALL SFLOAT + LD B,0 ;DEFAULT PT. POSITION + BIT 7,H ;NEGATIVE? + JR Z,STR10 + RES 7,H + LD A,'-' + LD (DE),A ;STORE SIGN + INC DE +STR10: XOR A ;CLEAR A + CP C + JR Z,STR2 ;ZERO + PUSH DE ;SAVE TEXT POINTER + LD A,B +STR11: PUSH AF ;SAVE DECIMAL COUNTER + LD A,C ;BINARY EXPONENT + CP 161 + JR NC,STR14 + CP 155 + JR NC,STR15 + CPL + CP 225 + JR C,STR13 + LD A,-8 +STR13: ADD A,28 + CALL POWR10 + PUSH AF + CALL FMUL + POP AF + LD B,A + POP AF + SUB B + JR STR11 +STR14: SUB 32 + CALL POWR10 + PUSH AF + CALL FDIV + POP AF + LD B,A + POP AF + ADD A,B + JR STR11 +STR15: LD A,9 + CALL POWR10 ;10^9 + CALL FCP0 + LD A,C + POP BC + LD C,A + SET 7,H ;IMPLIED 1 + CALL C,X10B ;X10, DEC B + POP DE ;RESTORE TEXT POINTER + RES 7,C + LD A,0 + RLA ;PUT CARRY IN LSB +; +;At this point decimal normalisation has been done, +;now convert to decimal digits: +; AHLH'L' = number in normalised integer form +; B = decimal place adjustment +; C = binary place adjustment (29-33) +; +STR2: INC C + EX AF,AF' ;SAVE A + LD A,B + BIT 1,(IX+2) + JR NZ,STR20 + XOR A + CP (IX+1) + JR Z,STR21 + LD A,-10 +STR20: ADD A,(IX+1) ;SIG. FIG. COUNT + OR A ;CLEAR CARRY + JP M,STR21 + XOR A +STR21: PUSH AF + EX AF,AF' ;RESTORE A +STR22: CALL X2 ;RL AHLH'L' + ADC A,A + CP 10 + JR C,STR23 + SUB 10 + EXX + INC L ;SET RESULT BIT + EXX +STR23: DEC C + JR NZ,STR22 ;32 TIMES + LD C,A ;REMAINDER + LD A,H + AND 3FH ;CLEAR OUT JUNK + LD H,A + POP AF + JP P,STR24 + INC A + JR NZ,STR26 + LD A,4 + CP C ;ROUND UP? + LD A,0 + JR STR26 +STR24: PUSH AF + LD A,C + ADC A,'0' ;ADD CARRY + CP '0' + JR Z,STR25 ;SUPPRESS ZERO + CP '9'+1 + CCF + JR NC,STR26 +STR25: EX (SP),HL + BIT 6,L ;ZERO FLAG + EX (SP),HL + JR NZ,STR27 + LD A,'0' +STR26: INC A ;SET +VE + DEC A + PUSH AF ;PUT ON STACK + CARRY +STR27: INC B + CALL TEST ;IS HLH'L' ZERO? + LD C,32 + LD A,0 + JR NZ,STR22 + POP AF + PUSH AF + LD A,0 + JR C,STR22 +; +;At this point, the decimal character string is stored +; on the stack. Trailing zeroes are suppressed and may +; need to be replaced. +;B register holds decimal point position. +;Now format number and store as ASCII string: +; +STR3: EX DE,HL ;STRING POINTER + LD C,-1 ;FLAG "E" + LD D,1 + LD E,(IX+1) ;f2 + BIT 0,(IX+2) + JR NZ,STR34 ;E MODE + BIT 1,(IX+2) + JR Z,STR31 + LD A,B ;F MODE + OR A + JR Z,STR30 + JP M,STR30 + LD D,B +STR30: LD A,D + ADD A,(IX+1) + LD E,A + CP 11 + JR C,STR32 +STR31: LD A,B ;G MODE + LD DE,101H + OR A + JP M,STR34 + JR Z,STR32 + LD A,(IX+1) + OR A + JR NZ,STR3A + LD A,10 +STR3A: CP B + JR C,STR34 + LD D,B + LD E,B +STR32: LD A,B + ADD A,129 + LD C,A +STR34: SET 7,D + DEC E +STR35: LD A,D + CP C + JR NC,STR33 +STR36: POP AF + JR Z,STR37 + JP P,STR38 +STR37: PUSH AF + INC E + DEC E + JP M,STR4 +STR33: LD A,'0' +STR38: DEC D + JP PO,STR39 + LD (HL),'.' + INC HL +STR39: LD (HL),A + INC HL + DEC E + JP P,STR35 + JR STR36 +; +STR4: POP AF +STR40: INC C + LD C,L + JR NZ,STR44 + LD (HL),'E' ;EXPONENT + INC HL + LD A,B + DEC A + JP P,STR41 + LD (HL),'-' + INC HL + NEG +STR41: LD (HL),'0' + JR Z,STR47 + CP 10 + LD B,A + LD A,':' + JR C,STR42 + INC HL + LD (HL),'0' +STR42: INC (HL) + CP (HL) + JR NZ,STR43 + LD (HL),'0' + DEC HL + INC (HL) + INC HL +STR43: DJNZ STR42 +STR47: INC HL +STR44: EX DE,HL + RET +; +;Support subroutines: +; +;CON - Get unsigned numeric constant from ASCII string. +; Inputs: ASCII string at (IX). +; Outputs: Variable-type result in HLH'L'C +; IX updated (points to delimiter) +; A7 = 0 (numeric marker) +; +CON: CALL ZERO ;INITIALISE TO ZERO + LD C,0 ;TRUNCATION COUNTER + CALL NUMBER ;GET INTEGER PART + CP '.' + LD B,0 ;DECL. PLACE COUNTER + CALL Z,NUMBIX ;GET FRACTION PART + CP 'E' + LD A,0 ;INITIALISE EXPONENT + CALL Z,GETEXP ;GET EXPONENT + BIT 7,H + JR NZ,CON0 ;INTEGER OVERFLOW + OR A + JR NZ,CON0 ;EXPONENT NON-ZERO + CP B + JR NZ,CON0 ;DECIMAL POINT + CP C + RET Z ;INTEGER +CON0: SUB B + ADD A,C + LD C,159 + CALL FLOAT + RES 7,H ;DITCH IMPLIED 1 + OR A + RET Z ;DONE + JP M,CON2 ;NEGATIVE EXPONENT + CALL POWR10 + CALL FMUL ;SCALE + XOR A + RET +CON2: CP -38 + JR C,CON3 ;CAN'T SCALE IN ONE GO + NEG + CALL POWR10 + CALL FDIV ;SCALE + XOR A + RET +CON3: PUSH AF + LD A,38 + CALL POWR10 + CALL FDIV + POP AF + ADD A,38 + JR CON2 +; +;GETEXP - Get decimal exponent from string +; Inputs: ASCII string at (IX) +; (IX points at 'E') +; A = initial value +; Outputs: A = new exponent +; IX updated. +; Destroys: A,A',IX,F,F' +; +GETEXP: PUSH BC ;SAVE REGISTERS + LD B,A ;INITIAL VALUE + LD C,2 ;2 DIGITS MAX + INC IX ;BUMP PAST 'E' + CALL SIGNQ + EX AF,AF' ;SAVE EXPONENT SIGN +GETEX1: CALL DIGITQ + JR C,GETEX2 + LD A,B ;B=B*10 + ADD A,A + ADD A,A + ADD A,B + ADD A,A + LD B,A + LD A,(IX) ;GET BACK DIGIT + INC IX + AND 0FH ;MASK UNWANTED BITS + ADD A,B ;ADD IN DIGIT + LD B,A + DEC C + JP P,GETEX1 + LD B,100 ;FORCE OVERFLOW + JR GETEX1 +GETEX2: EX AF,AF' ;RESTORE SIGN + CP '-' + LD A,B + POP BC ;RESTORE + RET NZ + NEG ;NEGATE EXPONENT + RET +; +;NUMBER: Get unsigned integer from string. +; Inputs: string at (IX) +; C = truncated digit count +; (initially zero) +; B = total digit count +; HLH'L' = initial value +; Outputs: HLH'L' = number (binary integer) +; A = delimiter. +; B, C & IX updated +; Destroys: A,B,C,D,E,H,L,B',C',D',E',H',L',IX,F +; +NUMBIX: INC IX +NUMBER: CALL DIGITQ + RET C + INC B ;INCREMENT DIGIT COUNT + INC IX + CALL X10 ;*10 & COPY OLD VALUE + JR C,NUMB1 ;OVERFLOW + DEC C ;SEE IF TRUNCATED + INC C + JR NZ,NUMB1 ;IMPORTANT! + AND 0FH + EXX + LD B,0 + LD C,A + ADD HL,BC ;ADD IN DIGIT + EXX + JR NC,NUMBER + INC HL ;CARRY + LD A,H + OR L + JR NZ,NUMBER +NUMB1: INC C ;TRUNCATION COUNTER + CALL SWAP1 ;RESTORE PREVIOUS VALUE + JR NUMBER +; +;FIX - Fix number to specified exponent value. +; Inputs: HLH'L'C = +ve non-zero number (floated) +; A = desired exponent (A>C) +; Outputs: HLH'L'C = fixed number (unsigned) +; fraction shifted into B'C' +; A'F' positive if integer input +; Destroys: C,H,L,A',B',C',H',L',F,F' +; +FIX: EX AF,AF' + XOR A + EX AF,AF' + SET 7,H ;IMPLIED 1 +FIX1: CALL DIV2 + CP C + RET Z + JP NC,FIX1 + JP OFLOW +; +;SFIX - Convert to integer if necessary. +; Input: Variable-type number in HLH'L'C +; Output: Integer in HLH'L', C=0 +; Destroys: A,C,H,L,A',B',C',H',L',F,F' +; +;NEGATE - Negate HLH'L' +; Destroys: H,L,H',L',F +; +FIX2: CALL SWAP + CALL SFIX + CALL SWAP +SFIX: DEC C + INC C + RET Z ;INTEGER/ZERO + BIT 7,H ;SIGN + PUSH AF + LD A,159 + CALL FIX + POP AF + LD C,0 + RET Z +NEGATE: OR A ;CLEAR CARRY + EXX +NEG0: PUSH DE + EX DE,HL + LD HL,0 + SBC HL,DE + POP DE + EXX + PUSH DE + EX DE,HL + LD HL,0 + SBC HL,DE + POP DE + RET +; +;NEG - Negate HLH'L'B'C' +; Also complements A (used in FADD) +; Destroys: A,H,L,B',C',H',L',F +; +NEG: EXX + CPL + PUSH HL + OR A ;CLEAR CARRY + SBC HL,HL + SBC HL,BC + LD B,H + LD C,L + POP HL + JR NEG0 +; +;SCALE - Trig scaling. +;MOD48 - 48-bit floating-point "modulus" (remainder). +; Inputs: HLH'L'C unsigned floating-point dividend +; DED'E'B'C'B unsigned 48-bit FP divisor +; Outputs: HLH'L'C floating point remainder (H7=1) +; E = quotient (bit 7 is sticky) +; Destroys: A,B,C,D,E,H,L,B',C',D',E',H',L',IX,F +;FLO48 - Float unsigned number (48 bits) +; Input/output in HLH'L'B'C'C +; Destroys: C,H,L,B',C',H',L',F +; +SCALE: LD A,150 + CP C + LD A,ACLOST + JP C,ERROR ;"Accuracy lost" + CALL PIBY4 + EXX + LD BC,2169H ;3.141592653589793238 + EXX +MOD48: SET 7,D ;IMPLIED 1 + SET 7,H + LD A,C + LD C,0 ;INIT QUOTIENT + LD IX,0 + PUSH IX ;PUT ZERO ON STACK + CP B + JR C,MOD485 ;DIVIDEND=DIVISOR + EXX + EX (SP),HL + ADD HL,BC + EX (SP),HL + ADC HL,DE + EXX + ADC HL,DE +MOD482: CCF + RL C ;QUOTIENT + JR NC,MOD483 + SET 7,C ;STICKY BIT +MOD483: DEC A + CP B + JR C,MOD484 ;DIVIDENDR, A=&C0 if L=1. +;Note: The last coefficient is EXECUTED on return +; so must contain only innocuous bytes! +; +POLY: LD IX,2 + ADD IX,SP + EX (SP),IX + CALL DLOAD5 ;FIRST COEFFICIENT +POLY1: CALL FMUL + LD DE,5 + ADD IX,DE + CALL DLOAD5 ;NEXT COEFFICIENT + EX (SP),IX + INC B + DEC B ;TEST + JP M,FADD + CALL FADD + CALL DLOAD5 ;X + EX (SP),IX + JR POLY1 +; +;POWR10 - Calculate power of ten. +; Inputs: A=power of 10 required (A<128) +; A=binary exponent to be exceeded (A>=128) +; Outputs: DED'E'B = result +; A = actual power of ten returned +; Destroys: A,B,D,E,A',D',E',F,F' +; +POWR10: INC A + EX AF,AF' + PUSH HL + EXX + PUSH HL + EXX + CALL DONE + CALL SWAP + XOR A +POWR11: EX AF,AF' + DEC A + JR Z,POWR14 ;EXIT TYPE 1 + JP P,POWR13 + CP C + JR C,POWR14 ;EXIT TYPE 2 + INC A +POWR13: EX AF,AF' + INC A + SET 7,H + CALL X5 + JR NC,POWR12 + EX AF,AF' + CALL D2C + EX AF,AF' +POWR12: EX AF,AF' + CALL C,ADD1 ;ROUND UP + INC C + JP M,POWR11 + JP OFLOW +POWR14: CALL SWAP + RES 7,D + EXX + POP HL + EXX + POP HL + EX AF,AF' + RET +; +;DIVA, DIVB - DIVISION PRIMITIVE. +; Function: D'E'DE = H'L'HLD'E'DE / B'C'BC +; Remainder in H'L'HL +; Inputs: A = loop counter (normally -32) +; Destroys: A,D,E,H,L,D',E',H',L',F +; +DIVA: OR A ;CLEAR CARRY +DIV0: SBC HL,BC ;DIVIDEND-DIVISOR + EXX + SBC HL,BC + EXX + JR NC,DIV1 + ADD HL,BC ;DIVIDEND+DIVISOR + EXX + ADC HL,BC + EXX +DIV1: CCF +DIVC: RL E ;SHIFT RESULT INTO DE + RL D + EXX + RL E + RL D + EXX + INC A + RET P +DIVB: ADC HL,HL ;DIVIDEND*2 + EXX + ADC HL,HL + EXX + JR NC,DIV0 + OR A + SBC HL,BC ;DIVIDEND-DIVISOR + EXX + SBC HL,BC + EXX + SCF + JP DIVC +; +;MULA, MULB - MULTIPLICATION PRIMITIVE. +; Function: H'L'HLD'E'DE = B'C'BC * D'E'DE +; Inputs: A = loop counter (usually -32) +; H'L'HL = 0 +; Destroys: D,E,H,L,D',E',H',L',A,F +; +MULA: OR A ;CLEAR CARRY +MUL0: EXX + RR D ;MULTIPLIER/2 + RR E + EXX + RR D + RR E + JR NC,MUL1 + ADD HL,BC ;ADD IN MULTIPLICAND + EXX + ADC HL,BC + EXX +MUL1: INC A + RET P +MULB: EXX + RR H ;PRODUCT/2 + RR L + EXX + RR H + RR L + JP MUL0 +; +;SQRA, SQRB - SQUARE ROOT PRIMITIVES +; Function: B'C'BC = SQR (D'E'DE) +; Inputs: A = loop counter (normally -31) +; B'C'BCH'L'HL initialised to 0 +; Destroys: A,B,C,D,E,H,L,B',C',D',E',H',L',F +; +SQR1: SBC HL,BC + EXX + SBC HL,BC + EXX + INC C + JR NC,SQR2 + DEC C + ADD HL,BC + EXX + ADC HL,BC + EXX + DEC C +SQR2: INC A + RET P +SQRA: SLA C + RL B + EXX + RL C + RL B + EXX + INC C + SLA E + RL D + EXX + RL E + RL D + EXX + ADC HL,HL + EXX + ADC HL,HL + EXX + SLA E + RL D + EXX + RL E + RL D + EXX + ADC HL,HL + EXX + ADC HL,HL + EXX + JP NC,SQR1 +SQR3: OR A + SBC HL,BC + EXX + SBC HL,BC + EXX + INC C + JP SQR2 +; +SQRB: ADD HL,HL + EXX + ADC HL,HL + EXX + JR C,SQR3 + INC A + INC C + SBC HL,BC + EXX + SBC HL,BC + EXX + RET NC + ADD HL,BC + EXX + ADC HL,BC + EXX + DEC C + RET +; +DIGITQ: LD A,(IX) + CP '9'+1 + CCF + RET C + CP '0' + RET +; +SIGNQ: LD A,(IX) + INC IX + CP ' ' + JR Z,SIGNQ + CP '+' + RET Z + CP '-' + RET Z + DEC IX + RET +; +ABS2: EX AF,AF' + BIT 7,H + CALL NZ,NEGATE ;MAKE ARGUMENTS +VE + CALL SWAP + BIT 7,H + CALL NZ,NEGATE + LD B,H + LD C,L + LD HL,0 + EXX + LD B,H + LD C,L + LD HL,0 + RET +; + END diff --git a/tests/ALLTESTS.BBC b/tests/ALLTESTS.BBC new file mode 100644 index 0000000000000000000000000000000000000000..3603e4d838eb91edba0b68fe941b49c3095a1e15 GIT binary patch literal 384 zcmWgPVsKMcuvJ*6sNy#xN$T2b`I7CSa zC@qH}?Gzd0>IRe6z>szg3i1zvNgH8GM|g&WxIzuL!H{szW+6*&03PU#7$J5yrs+lu|;U>u2yh3>lTA9v$lwNq0YDhVkOG8xK=}W^V_r$7l0uKdFJ6`k240mWhUW?g5<^mpOH_0emgH#| OS!il1*w`r~h5!KJm{#ck literal 0 HcmV?d00001 diff --git a/tests/ARRAYTST.BBC b/tests/ARRAYTST.BBC new file mode 100644 index 0000000000000000000000000000000000000000..e956662ee03da640b277fdb16ebf259e0665288d GIT binary patch literal 12752 zcmbVS4QO1|wocNSbTY|KroG~AlO}IBO{Qnklj)rKNt@W#=EtB?tEg8*q?jg?CcY#S zCe!+Zh`0LWA|fIpB61P0h*w19BI5I1M7$y*A|fIpeWBOuQz%S)b z*B*Kmk!+nP9N^(+ij)5;%f-b~xl){x3n%A~7t69VE$u8za$;dhF3sLu#60Qoy07K3 z!!xB)^1vbKNhu$&O|Hj{gM(;Y5$WqJbgyH<4K$hp;DElxLMK;4qp2Et%0l<7hDK8r zbY!7Ublm9^Oym%i%)cSwoW@|s4F6=me$S*ph9oKn2m1;j$a&bnF?S7MufvcEE>Cbz z7&vCVflCJAJc4`1z_DBmTu%^=#*4gIC!AOP-X&u|@{e>N*Rrg6RoylZ8 z(bdgeYH7MFnej4N{PVlb4>)8cGxegg?1PaVOwZ2wR+qY`{=BD+!5E#k zK2ld^Iw_}!JctP&^+&3nF#Z%x=w$%+T)pUc*@vUqV3o$ox4a(W->$dogQA51Jy4p> zdwapCJj-&|2O30i5+F%0o68pl_U%W%0{K*fD0ULa@UZGs&lR!jtOim11xWXm#kskX zyrWc}o7&k;DsYZC`(wS>^$QVjmD0=Er6T)}NoKSmBo%8opWP7Swl;{=js`2KGCZWU z+a)=>Bu_3t%nK)qQ&6vDgI2GC()?YShKsUiNQ11yo-qxw4ttJjkagH|a|76Oyg{_j z`Q+U2yKCe$D5$`j4~c!JFv`1*velGS?zNyy!Yd493y|%gdh}TtuZV&Bd^GE32`%aA zpTeUCBl#84_Yh-|`9W6$lL5=ZLk(6$&*KF7XBHQWd)v#bB4^0GS?;}HdwB=4y?N^0)vzhZ2PK{m8(KDr z!lj$6x>jZ;Dl%y7a=KhB%F0Y}wk&6g6N~cX(!`14kci7o+69QdP1HgD`>crPP4kvR znEb3f#8|z=@hdlp^!5H!cg&RLiv4V0a$;#|_QV3B1lY=Au{=>JmBIPLw{Bu*nIX9G~4gyTxVGM8D-MIOkN2ih%;CDS7_(xl~>z&zZW zOcv;=3_{7TCn5^zh;=X8+RL+*nfYR6c2YV^mGbOlMa~tcEB%#He|h%AOeHlW4(*R< z(?2Nt^_y?~x~-Zwx)Ey>10#0HS_k^8b%3pw9>Hy?aKvI6=JZ!{Cv5Db1UFeE%bjuN z&KT)Ta+IGVqx3#ZPsN?W04c$35s|&!5DNckHqt)U^F7k>pzeJ#n?|(WuRF!Q3S$uQ zY6GIT-$Q{F1byw1IeDK`H5TxmBTw7u4P({($^C3&gRFLgWLL>yeuu^x_Kq=o zpO1*>E0NDc`VH2=s=RdmY`=@tkiTE zU|Kw41#CW9e*|jGabu2>p^>;9!SdP%CaTpU0wYkP8Uc&I2$$Fqh&Q3>(4}72spL0%z~J;cVH9M* zAq+}e`^ODN(y5*TnJ~fg_=Ukf%7s(c8Q>l#xEdtG8W8K?WcZe-aHf3HR8mnp8E#*| zpzm6B2qeGlciJ8nGx1nuzwM`O4~s9*^RVq38u{Iz=yJ4oJV~CcyhSJ7uFGkt3a?>6uDOl zff+jUsU6)I{QzL$MQi<_?q@B$G4Xe@8Mi9-RH5g&MzQ@zqAHkD(|I9c`qVFt=L;L+ zO>DD}TQ^%S>tiFN=l=1+;Ev72AZ9W4FJ=6pD9FRkkC5N1+UgG{fk>P((jix}DzYck z+M#`4h9@RIgLi?6Rp^Hh4|p5_jSg8za7{r{OplPBBYFzxDW0bTpLe{18#<=oP=0K) zNFMb$v39E3ee-6{Oz9+TNOCf2Uvsd_j7S{cTy4v9_zu`|;uO9EHrsih8W9$xh_wcJ zEGrTZ0XSf|@^J#jUaWwt4H)n{U!eY+>4%#PS}p*hA8m$Veol`s>G3@tT^GQ>`&nbG zbMw>VT@5i3r0UlyuhV0WC14d@EdWsfv@@|sWe{v%D`NOk^eT%nTD_ilYG}KRiD+N! zGm**1tg@;&cb;O5#ktwZ2|6y3&Qz(=zgR9!ot&f)_xeMzWjTy(#!I;)*q?GKca%0A ziuZ?|)Iq&txdnFsEhA{z@9uL4@SVrz2Q;*fLZuE8bQ=BQ)+=emUOgo3c{C<{t3kn^ z@Tk;OV^}oPxb!Ct^`Nn@r?F{Qq~#{{*t|>ff+3sm*wj>GY%&;(O@A;p{)iiHjS(SI zQW`qodO6q2fYf}(&4Exf47vk(w}3qsln~h@F<`L0tH9{~s_zwX!*mRUW6WPQBrwdF z4?tyT1oMp{7h|Ke=wCM^Fw77W~yb7IBq^p%7sZC#@@D>RF{u7@u^2 z{(vKZfPR8AVR2JaK-{FAXwqtwCM8mH@DOSe%<+;^E1n~%=HQ|O<^Ze0b5K)g4m4?X zN|Q3FId}*&N947b=z1%L;?=NUw33sh`Ng>+N=PVPHN7AEUj7@7ucDvCE{Mo-Ozin4 z_MZ|*<#&`8rVyv%)OcYE6sQ+Wqh82kh}ikqIXchZ@v|>OW&e|Rx+@1sje68P#aMK#xKNYTB zm4J3c_ctMa8fg;0Ino5bHy$iAbllXW7>B9opvgbs7u#;*F46{c*~mm}y`9@hg48}d zEIKRPLc1nfsvWP0-rMwd5&1)t$UW8sL1mo_iir@6dShX!R~DCgWr1yfx`_nl%84Fm z%Q<-l&;ONsJhAUkW%xM8C`d5)gH}56@5Ih*{0yCz zxDpJ&gUEL!5sxQG7tsT8XwP_D?7l7z?a4uVCdj5Q$m3dXrnJ&bv&Q6Zi7x}fPdr@$ zG%2Mk0j;t{jIVM*5uKtb7UE*hois(>fj^(3Ip{A>LN7cEz3?=boQ|J^Yo+7}VHRQ| z@+uF(C(L6KG$mh7|1p*w8+_%aL;Ju>ex`@2eLaXq3wq zHMa+y)Q#K%@zrut$C{x7GtFX8xfwc8Fk)Fx2e#is3$5jY9<2R&se zU&jYMXPL249~6C=SoC_cXnC7hG~gUX$vgW&vvSa!j;pFPnGT%;v+2+an-0Bz_dNTssE9 z3}dN_CSVpFxY6p=bq{v>M|;&plcNT%ml$jS{fj1m})Z4g*!ix8cc3absP&$gu4;0=;KAv*H@NTIW>Er&$4EOuQf zg0f(p_2WkPXw*C00dweh2h0swNW2C)He=s*h~(;CDNa)aelz8SJethif>?<^yA384^^Q+Kuu>DgRfa! z>q*qfm4BVWV*4zES9!}KTCbuJF@=x9Cs||fTVUf=);uYprPe&k`b3E2vd@FHkFpZq zh;wq@L%fv5|Ge08KBO;~{w(Ifh|nF3-!`_+^8u9dp=8!{(c-s>*7;iZFWOtb6FYiZ zYuvw>hd*5rJJPm~IZI~!nlsOLFLvy=eat-F$2Tu_kDxD9%ja^i+gmvbMASwJw~I*1rTlVt1?|`1#F4f_`pa7(y^#Co7RW_hesAlt z{=hkr?x6D;|BFwE0^bO*aIC`($f;UI;jvch05-h$UH&vkRz)kL9@(l|kJ_N}Rc)&N zlLMzOf8L@SRm@pXBG8nIO!b?63Qa@-)uRaKTZ7|E*y02VUW7w6GTM*xKN*~W7MOX^r2nZPLf6$Ib#20lw^lC?doWYnYUSqIug=QyotjU6_A zU7Jpp61TJklBJwTOyS$6NO`e$p^dD{Bt=LL-o}+t|7Y)Jx~Q(CMB+}M+f>OD+fFn3 z>N3~EfEzbuuB_Po1jF^h=+`ZCJ;PuSMJ+f}=6aEcQyI{!ZOD7xq{n;o_!y7K88GLo zfWTJW3;m&OgB7clHqjADSkZ@eb+0v1C2dl)wJTN-=-zEWs47`$6uV8?D*+^buiK7q zyhMKOniUZGT#I155*4jN$4Oje8Ayojhl#S_c5kXyS0^@DwYo7OmZNXzJ9{;jqizzoL=S4m$P_Rm(d;Nk{XU2|THY2}YH8O7vE~ZMV&vKIDdWq(>E$CyjOy+VFJFBfmJ6P1>P3N?Mb|8sI z_YU{xM-vqPQfo)EK=QV0O_eKFg6O<<42^RwS&CfNcJcSjp=^3hni{TYLrE;tS(JHG zqb{M}=w4js*xVZMYdMxZZpn)2nA4VPIjFl)Ct9hSCjR+kXS$1`34Lsgciz~$p(nQ< z`!)9HTbN!HoX=DIVSP2Tj8!dT*)DxzLe)Rul#2;kF{-!o5pYB0siT%tvQdBJkbaEM zgCCUbqL`x}KCJfXUFTiYa7;hKU1YLp5-;e~`-*-&-I-5G(@aTJm6BXYN^$`yiASa+ zKPM%5-;~65DS0H>MdA&ehE6d9TPLmYBhsBTU3muvRQZ+~ySs zz;J*Ej-$wufZ28!ulbJJ{C-5(d=P>AFtof65G)9Y=Rpicb^?SE0aQ-3FHCKZhvD*z z+#RpjbY%+eQ-I4anFwE%&&x|>RKg2nJRN?Bc03opAo1ESsJDJW;`LuZzx;{z_=cAF zHh|ZEf$QZPisRcZ^*O{I@N$^ez8?Ok67N9w6po+CekV-P_t1eNo86FmYW@g_$9G_O zijuDY2Ylz1q*}fO6!5(`clkvGe7==K@&>DZ1sJehw@D7guOsBs&0fh^%RQo|v}E9z z9EdJMz!MsLlM&G>sIOh1_2F`%G%*(pDOhINk*;IfRZIfumha?=B)SDP^a`G4>~_@D zFTlX&n#~a%5WzspQ|t-h546D8D1KO=U-*CB(WuoG{!F{g%Bb-f;Y~L7Fp9k@)M%@D z7slJ00;m=u literal 0 HcmV?d00001 diff --git a/tests/ERRORTST.BBC b/tests/ERRORTST.BBC new file mode 100644 index 0000000000000000000000000000000000000000..682e3e1fce1ae4490a564596b5abb9bcfe7b5c63 GIT binary patch literal 4224 zcma)0mMC=ju>H;KX7 zwRYFxa`2-+C`gD_C$&GS{d|za-tkF z?>#4LJ3;l2_1g2zy!U3_o0)g)wonU{V$-&3_8M5O>$u=sp6|uuafPuXp-ZqFhN}?M z*%38#4IYFy;Yop|;RZ`5L&Y#;;5?)OU!oZ}gY)4JNEM?TTM>YzefaqRa|ON)+bLw2`g`%Wp1?6LwS6&VR$*p#9?&DcwPD#li@ego z=?UU@pcmBs+5s*tsWClr02}+eWGDFG)2g0`X!r~$c+Ij`acd2qjos*g4T94+;{$ND z?>#)kI)(2NWL5Q%*!jrVgqRCoT*ItbOnrX`mph0{-PyqzVGstB+TJT)=AP-4(xEaH z#*NG;gBp*-royr0#PKebL9Ih2iyZCl9T5#a;gRDKNuuB?7w+zq+ydYcqJXpEdnJ}a zt0aGi=(ZMqhV%t>k-i78c&WC#~=ZF&|st6;jWxy9}+1wh&-JXTZu3pK9LKamXn z-ivjIequ%Hi%>7|=;0Gb?nN8cB~KoDg3oDr%l6H)B26%G1M*+?%9Sq%fj%Zq<4kR{=3%0M@)n%4T!(4D2yolg@;Mbzc>=mw z^@RZ2g2X{K$NwO?6F4^Jwr7VYbK;}nPhou7cPSbAjstbaUSrwUgiey?iSx~3{z#1e zpD)CAV4=BDwy+|gm2z#3#jbW3c}h*L=#ywi4A}*%I|0}TXOb%^k;l8ZvHx~(SQBC# zjlsUS`rcc3R^bcbW{-;l(`7b!xPudB5k<3!BprdC)kTj6H3m^b&!!UO;~q3N97M^s zo>-YcPwWSeBqU7hX~9p`SW-I7S~LCHrUkC!V17?ajIv4#zNf~1Ah5i%X1Xk_53&;n6b@fCgKfY+?7!zRwwEY~d--F(+*>VW{dJvW=rtHQFTDAHNo z)(5{XRp@lKKuspc=#94#yb-|C`lv+ckS;A{hPj+7=DKy3@^raoo9-4{eNO?<+&YaG9uGiRi1vr>2|(8m zfJRSChyr>YqBQD1U{;&sgBF@TRsI>HWU!H3-_DD9bb`HJFXX5^x;FlL7s(GT>AeMT)k*Gi;Ohi8&z-LEz3 z7EZ5h)!EdLAoUYu_n*0N=3!8kY_V7fKL=uRU>Dq+#wFzqdH8kP;KwYuf8 zY`krO{P^-nvW7Ja*UJ!bmbfPT?ayttzMZ z2k#RTc`4RO{6|oh)eN{PSdWk$bC{NNlR{0K{owfLgYa+3CVA%oTJwYS%S7|fewNkmNOpn_#b~}@%z#3Z zC}!vRmB{1$4~ze>&5<)kmyP?fSPCfzP>|Yi#o53}RoVNV?V~I1*BE=T?^WP^WBM}t z$e-v3uStf6{Z$%o%!Q9DC^`HWl2B7;gei4jX2<^4htllcJsQw9?jYZ);(faRUwyB! zzT5iQ?MM1wmG@}&!DIb-+BL=SfDRA9Fm-ZlKG}Z-F2Koq0A*;=u;u04TX&jutY0R! z4Gz_C*Q$bv2MDthC?7*wfiiCIYORWyUcpJ-V4paN#-1Q!xY2i~XN%tMi>8NqC>DA_ z`(+C^F3M0#35;=p8)dov-5WnUyx8BhfY8mGkF5-aZoT!JD~%Ou!$Sj~4TVDIR=6KS Jar{Ak`yYgSnvMVf literal 0 HcmV?d00001 diff --git a/tests/EXITTEST.BBC b/tests/EXITTEST.BBC new file mode 100644 index 0000000000000000000000000000000000000000..95b72428290bf280b0b47527d8beeaf2c192a8df GIT binary patch literal 1261 zcmZvcKWI}?6vpqn&yY0DY4eKIztO|15m6~=YTEjU58JBP7K@Y)MZ`fH|6onUMsaW` zQXRB|gE%;dgM&CYh(iT&aIj8A92}&BP_a-*QD{LTv3~cyyclDa2k+eP-t+sud)|wM z#SgZJu4c0rvgi2lNZ&B$G84Ip*49>=to34n`{I0n+jxfC64bN}g??2?CQxZl(Dq$o z(UYWjvb2=qX^yhmNr9xuQy`5;^ARmfyD6T6F6|~$T%fw+Vo)7VkrQH;2RW^}SfgTz z=h@+9zQs#Ql@$Y8Rev3-0jN?Gys1P~KP`M!%LBk2^I@@l5mJz9npwWfd9ogh70!)c z%w#7V&KKv%dM4)oDKx(n-8-<$u29(&egl9#iZk$D%u&Nfcmals!wa-&UaX>*^5HpG zy^8#b!rx#{?}~gcal>7(;DN6*%HRz~E%43?@bE^%2e1tQ>@`XNod5`QptRwjUrHii zBu*QV|nVh;^vTWh?G z^#;$n^~9(O`ngdR^o&s>=+Ijuk0Yt^lX4UHBaVI1y)?2vUGU@eiY`^5u6U@w%cz?} zvW(hZ8cuI-s7ZSLwo1QWJ5menL|Kh*LgK~2OMjf=hoAw1PIjtHr>0re+Hf%P9+VE% zjmT~_hZHz1S1C9qb-350f8lkLvd3G$qt@?x>yOIo@uzZudzC_cc6ySP-a}tilgzzj zy^vKAzm`=Izmqj04u3#%J(cyJWs%jvDQfr%Z#~L}vfr}&Uw`GNLr16kQ}`z=dS8Sz z;UQvbkIkm}i`Kt_hm7+Xa@$Q7q{+6SQRr_3pIW qfeFX5%HtRBM?T2?r0G!Xtcjo5-=7$t8NYOSER)NO;%6q-*8Tvh-g1oq literal 0 HcmV?d00001 diff --git a/tests/FILETEST.BBC b/tests/FILETEST.BBC new file mode 100644 index 0000000000000000000000000000000000000000..1c1bf62c4d616c526f11621e3186b233ddd3d292 GIT binary patch literal 1920 zcmZvdU1%It7>3WzkF(k7*^MSyZ0&}R*|p53-DQ7_O2`Jc*%>-EnXH?M%@!|2vz2HP zi%CUAq!yK;q9P(vM5KrpqD5>G5$T1f6cP18#Cjp3VvE>frAR4a{LVSMGnp`ZvAgHY z`FXzgeb1asf?NWlb!cT}apgWZu(;HLwa)6=YOz=}=)fScb5H}rvu3?wE|)VX9VV-b zk9BUu-chQX#IBt%?OdMf6><*jS_!Vw%s9CW&6eYOxUf}kfHmFp+F(0VmO=Y%@+-JF z?jtCdDixY+;=JQodwhaTrTekoDzIq=3OT&zU9J;u~Ydr@m@55+kD<1xGTg5ZA!$94H% z^7%8z0)Fn=Mrr%s+Jt{1YAgLy>=pRtSFtds$qF!81&4WAg-V{8pncELvwv*byjh?1 zz;YWfWA}n{IgGINKOX^uR1JL9wo6P6ZHL6`E=hhw$E04}nTF(>C4#iOKDl>az15gC zXwt=TK_us~)r(~E9&GR=v9$IrNz9ru9eP+|?y^8*u1jzf3T2u)EU`Ft6Gzj}_NHzO z;m|ACi;}Tu^7%ZOZ%Dmle!y#qe}?ZgQJ$xk)_bX`GNR zfJ0MzWYmAmKQt{IA$SMxl6~>5c@JGS=yeBVCRX4i9XKd=HLWuKDi)A_Dhe_Ank>{R zRI0a7?Ktj^XW_%Bq46(eq2qV5uj5ZX*Y@)P7uRt^CWihNG>Eam;eR=_@9;HBgo64u z>=lP1kyE;QWs2B|YPtmz55|-1RaniBAU{77w<@fJ)NUmt;1o^~0^V?^;tM!E({SuI z^eor!R(da_)cs1x{WT@z{u4?lokyeCQ!guAT83A^BlS9hIaGU_fl>W^#W(k3pKaS` z0o&vrYjSUZ_H}^vLm2IsFxsDCw11+|5=8B4d2K@FS_(+^P8n1gW_(yhvrBZqRu>K} zFF#slca}Ij15MFY3A)m6s_S4_tvVQnvD41@z9LMwTa;3>DO`U65>-yGzv{@39+rJvxvbrWLrKF_`I))V6_0~nQOG&db zWXKpg$`~?a3>h+p3>ia)$dDp3WQYuzB148qk)blB*fFJu6xsZ~cex~Yy-T`6FL&?V z@7?e7zW4jSckQ*dzi8X|aYachGc-Or9twq$v4bg^m*?_xxM(A;O*Yc9)wW6#$7VC> z!|6O#&?isROg1|^7bTuSI%rEF7jf4s9v;D3%?4rwbiAHgJ2ggS^ zF4HyA7)L;Y1q35u9zqwWMCcg8cyrh^Y||m$zg?32!<~Htc>EgiOtUn$_aj_TY%4@K zfrIZfZbWn60F`z~xJx)^ixU4uD;nB8hk3}zl+8g8*she=t{d5IR$;qk&UU8?+dUJu zr6Qa7(6&MYr1`P!Tg>AsjUS($k!f0)mX-WuKAlyFZ_UW;vPVfvoqd(YPM9m$WG^b% zW;ZApuvb=aHv&u)+>5YE3J&vry@Dy023N3V!oGrVQgal)!=1#J!|gg9PlCyR#)@g3 zj^|5+myCp0s}SBWCtR#Tc-w^VZjsP)pA!ZE*Zjb4spYbfdllTzKLPhxb{4WLa*o$w zlz3|#TtpNSd9J}>5QX@<(4;HPu%n`|by4&uiq$p5Mu#>LQj>IWZJG}{tkSNZLaZuR zB*LmLUTFl{eBhd4^5~)E>hQg25ROwU*Z=< z+3?Le#vj1w|Jj<+AoCw(z<(Qo|EmJ*c2$?T-c?!VExcbZbB9Zl*&A{(-~fYd?sZve z{W3<;YdzwMlJ-|z>$INLITERTojt3czC?U)fTrAgI^HtFi|7k>p)#KDJq=H*)(;A7 zu&9r~#<)JQ6v*D_s8z zLt^LZMyK^p49Bj`_c@#YVZi9tZF5>}0u)56xh45(SvOxIfe0Jz*o1~{-4ltPzJUZ? zami(mW%Dx4XX%klb}}EJ z#X|N?;{pA&Yfn5LAH+WiDuT*ZY{HZj&$o9ChQrK{yCV1{-V=;T#pyha^X_dEYz7iN zY>(ERpnZj*F><^I%ys8f9yPr4q8h?7NU0&Ibs^#vfG0@fbwumr9Uz4|VxJ-a!7sny^9|U2fCt>)cWDVw2lUB1KzU52Rva z<%+erxnjK#U>6f16mS<5)0&uK+Idh@ELf0iH!{&A+lzCfWCM_l1+zac*)X1mRkI*j zN)6FTW(*N0+)T2jqZ)Kj(lp!2G|MsSlN+HfNqELceg2uKFO^YW-3av!9rfY{sD<0^ z71DIqg84p}eGkB#%qqcx84>R?rwT?wVX|el0K~4C4dJ*z!=VUieZrErG!}1-SX9*0 zAacJzl-MFN5ri%g1rio@4-Vj?uds7tZx``I5eD}|8qGtZ`ZlRq@MN(4;&~+5gRJv7 zSeC~W2E)|(tU#mVstc4hXzxFbR?0C5!=(J{{suwKZF1P literal 0 HcmV?d00001 diff --git a/tests/INT32TST.BBC b/tests/INT32TST.BBC new file mode 100644 index 0000000000000000000000000000000000000000..b3b96820e45bb06b48333622dadbeb08ae026c8b GIT binary patch literal 2944 zcmcJRKWG#|6vijV6&9|7Scq6W4mPs?C#BPzHi>V*_olE z;y2_j+-|p*+e=U?7OpIJV7c9CEwxsl(^~DUj*X4woWprB={5#^&-0qzl#?wAXQVEg zE;PXPy}f_V$h4T^mPmU(mbBVAI3pGosA+a)+TFg3Bx_rq!_H zRNInz2pVIHtc`b;8nNJx#MTlNjgDwrP1KsC?sq8`NV#BVL_L<&g9ODI2-<3-!e?R| zPET`0W-p$_D9M;GK#=w4!R*}m8K<@`HDNRn7n%=}wAQFv+fZB~&ZRTd7jc`!;mpGb z0MwLK)=A9+;@&I0apZ~-7sbRnJRUT1!6)QiVYZA@u5hxX%t7=TJ0rC(QmtM`HBYLg z3-Le1eUn@m?vMMSIRy8i_bcwxSJB+lD35PP>!DA{^%2clb|6}MAq}uUJ)ZSLlB0O~ zl@y=6e7hHl=P|9<<;?jrM@w8zb75Dn+qL>mB$ftoC*wW?`@AQ+@i?A=)pSa|C*qMlq0QMSBBs(>4&Dt&U5H^{B$a|PUfbHjZ?!3Tsk6Bd)x z)cb@3D}Nqnx{VhTTeyAc9la-Vu@@AKuRTh!2G&~&{dZJ?(FXVv(61VA&Ocd=cM%nO ztA>6_RArmS^%lAV>m7db4MM|z$YKKuMZa7v*GfUT3S{uh`ucV!;&~SdRb4@)zT@Z{z>~ literal 0 HcmV?d00001 diff --git a/tests/SLICETST.BBC b/tests/SLICETST.BBC new file mode 100644 index 0000000000000000000000000000000000000000..bffbbabd0a7cfeaad2818d3776462f8694f509a3 GIT binary patch literal 9984 zcmbuFe`r%z6vtna*B{8P3=wf!-1E`a#-t@ln>6jJ=#*}auGXv!ks*sVvl%f;UnVkS zs0U6!P21XDR2DobK*!8-?c^*)jZAo3+BSR~Jk9 z@w|io%x*2@orxW}VktYB&ldB}4jY+E4Aj$UJhZMbkB~LEQt4w`hpidZ8z(Np$IprR zn1cpdGE_!IP8B<&A?C|0ULTc5V|;Wq8@4vf!*MZOWaCT6>mNK^Y10p4d8V7@?u}#6HWPHcZ#~EPD0nNn696B z#z2t^#FuXw$$h*p6e6DqICIA7x?EwKWTtWa2?WA(cEdog-Np`6P(pmhi|>*FF~Xer z(4q$fA`h{Mi=PlDSzQi?&0rCk4KHCXBAP3Y3K4OtwNM@wA`&THYRlt7M5J2i9&|)x z1DrvuBepVHQ`E{#HlVguz|u=d=}Ma#gfs?yYZKBI=vsr2CK^y=lKAp{a}yG4Ei?^X zdn;@!g~a<1%h^F3{0MdsqHqgNyBXVwuHz&)P;_N**7~?`PBkF=9Coe{|2 zTX69Ji-9TGLUb@?o2APexG8%IVfuTTcN$RtJ=t66R@L1pHuXq$6oOWq3e>Ofsq813 zrT1Y%-IC8`H_=_xJ<)6lptgAdX?K#eJBj?VU2JcaZThH<$RzI(9UZb!iW-T8<+#WHOf=^^Yn z1w3(vrDGszi1bAMY#^6kXhCf<*i#%6jB%UgfXXaTJ8r#-s*}m^jP@MDlN}ol)BRr z2!f+1QFmHi38J9|L7>xmBMn(FO5Mv^E=8$#GV6O`m~tbmOF1ipXu;b-XJY3hyIEv% zy9(KDIUA)jL2wGQxpK1_3oiXWj6|C83d=nbhI{n~TDsv6gS^o3T9rpEO7DVD@`$T| z;uU+`rEtFpf1(fl3_|gvxDPbvet{#{po)Wp}u9nxz*3w82Y6? z^lJ$9F9S}kdS1uSZ}p+yL#Rd>aB9UnM3UYgwV~^-L1^t|Al_UOUH*)9`Kva0^bbfb z-!8q5KtFYc|I$bQ3(@6Es~Vm0J_n6P-3B{4rx8>md;(O~WG3fTN%Qs5OCY*@zgDl> z$zhqfTzIj{IPYpjd!Zy3osBnMO_2o`Kqr}m$j2Jd;>Ds zA?n4%*;3r7ZtFAeLMA&y70je}cYUDGd;*#52vsrrT)%}QRW_r|Oq)$W82kiPLfxcD zRX(>#_ZV5TP(aCZWUVy%G-ujPC>+ry4kw$y&4AseT)BSd^zbSeNTGkvK)5hyy3+cS zAA?MV{@t0Zb5Q0MedYvYD)jHlF6yc)Yr}ifOg=~dncqdYjooLMKN>tD%?}lV}B~p=dST^AKSbS%WpBnaQ zlSdChvUDR-qVclhJ#H7GquS_=CnU6VAyTtT)%8M)<+MKgyu_C7Lq6t+fWVMJOvZ3dA}KTJZ}Dt{Dftsot%H)bzZ#|Up~?v zu{YVF$VmJCIQ}OTLguq(v@Fnqf1~!U%Wu=HZ98}DD&$JJar_%KL