diff --git a/Binary/Apps/Clean.cmd b/Binary/Apps/Clean.cmd index 2c3c648e..49043dc1 100644 --- a/Binary/Apps/Clean.cmd +++ b/Binary/Apps/Clean.cmd @@ -8,5 +8,6 @@ if exist *.hlp del *.hlp if exist Tunes\*.pt? del Tunes\*.pt? if exist Tunes\*.mym del Tunes\*.mym if exist Tunes\*.vgm del Tunes\*.vgm +if exist bbcbasic.txt del bbcbasic.txt pushd Test && call Clean || exit /b 1 & popd diff --git a/Binary/Apps/Makefile b/Binary/Apps/Makefile index 940d9ae2..dc268ac8 100644 --- a/Binary/Apps/Makefile +++ b/Binary/Apps/Makefile @@ -8,4 +8,4 @@ all:: mkdir -p Tunes clean:: - @rm -f *.bin *.com *.img *.rom *.pdf *.log *.eeprom *.ovr *.hlp *.doc *.COM *.BIN Tunes/*.mym Tunes/*.pt? Tunes/*.vgm + @rm -f *.bin *.com *.img *.rom *.pdf *.log *.eeprom *.ovr *.hlp *.doc *.COM *.BIN Tunes/*.mym Tunes/*.pt? Tunes/*.vgm bbcbasic.txt diff --git a/Doc/CPM/ReadMe.txt b/Doc/CPM/ReadMe.txt index af2b90fa..9365107d 100644 --- a/Doc/CPM/ReadMe.txt +++ b/Doc/CPM/ReadMe.txt @@ -7,8 +7,8 @@ *********************************************************************** This directory ("Doc/CPM") is part of the RomWBW System Software -distribution archive. It contains documentation for the CP/M -operating system components of the system. +distribution archive. It contains documentation for the CP/M and +CP/M work-alike operating system components of the system. CPM Manual ("CPM Manual.pdf") diff --git a/Doc/ChangeLog.txt b/Doc/ChangeLog.txt index 9b3b03b7..83247663 100644 --- a/Doc/ChangeLog.txt +++ b/Doc/ChangeLog.txt @@ -15,6 +15,7 @@ Version 3.5 - WBW: Auto restore TMS video on user reset (CP/M warm boot) - L?B: Added support for NABU w/ RomWBW Option Board - M?P: Reorganization of Doc directory introducing subfolders +- WBW: Upgraded BBCBASIC to v5.00 Version 3.4 ----------- diff --git a/Source/Apps/BBCBASIC/Build.cmd b/Source/Apps/BBCBASIC/Build.cmd new file mode 100644 index 00000000..715a96e1 --- /dev/null +++ b/Source/Apps/BBCBASIC/Build.cmd @@ -0,0 +1,23 @@ +@echo off +setlocal + +set TOOLS=..\..\..\Tools + +set PATH=%TOOLS%\zxcc;%PATH% + +set CPMDIR80=%TOOLS%/cpm/ + +zxcc z80asm -dist/FM +zxcc z80asm -main/FM +zxcc z80asm -exec/FM +zxcc z80asm -eval/FM +zxcc z80asm -asmb/FM +zxcc z80asm -cmos/FM +zxcc z80asm -math/FM +zxcc z80asm -hook/FM +zxcc z80asm -data/FM + +zxcc slrnk -/v,/a:0100,dist,main,exec,eval,asmb,math,hook,cmos,/p:4B00,data,bbcbasic/n,/e + +copy /Y bbcbasic.com ..\..\..\Binary\Apps\ || exit /b +copy /Y bbcbasic.txt ..\..\..\Binary\Apps\ || exit /b diff --git a/Source/Apps/BBCBASIC/Clean.cmd b/Source/Apps/BBCBASIC/Clean.cmd new file mode 100644 index 00000000..3de5bc26 --- /dev/null +++ b/Source/Apps/BBCBASIC/Clean.cmd @@ -0,0 +1,9 @@ +@echo off +setlocal + +if exist *.com del *.com +if exist *.lst del *.lst +if exist *.hex del *.hex +if exist *.prn del *.prn +if exist *.rel del *.rel +if exist *.sym del *.sym diff --git a/Source/Apps/BBCBASIC/Makefile b/Source/Apps/BBCBASIC/Makefile new file mode 100644 index 00000000..57ffda4c --- /dev/null +++ b/Source/Apps/BBCBASIC/Makefile @@ -0,0 +1,11 @@ +OBJECTS = bbcbasic.com +DOCS = bbcbasic.txt +DEST = ../../../Binary/Apps +DOCDEST = ../../../Binary/Apps +TOOLS = ../../../Tools +OTHERS = *.rel + +include $(TOOLS)/Makefile.inc + +bbcbasic.com: dist.rel main.rel exec.rel eval.rel asmb.rel cmos.rel math.rel hook.rel data.rel + $(ZXCC) SLRNK -/V,/A:0100,DIST,MAIN,EXEC,EVAL,ASMB,MATH,HOOK,CMOS,/P:4B00,DATA,BBCBASIC/N,/E diff --git a/Source/Apps/BBCBASIC/asmb.z80 b/Source/Apps/BBCBASIC/asmb.z80 new file mode 100644 index 00000000..f1a6951d --- /dev/null +++ b/Source/Apps/BBCBASIC/asmb.z80 @@ -0,0 +1,1010 @@ + TITLE BBC BASIC (C) R.T.RUSSELL 1981-2024 + NAME ('ASMB') +; +;BBC BASIC INTERPRETER - Z80 VERSION +;Z80 CPU ASSEMBLER MODULE - "ASMB" +;(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 5.0, 14-05-2024 +; + GLOBAL ASSEM +; + EXTRN TABIT + EXTRN CRLF + EXTRN OUT + EXTRN VAR + EXTRN ZERO + EXTRN STOREN + EXTRN ERROR + EXTRN EXPRI + EXTRN EXPRS +; + EXTRN LISTON + EXTRN COUNT + EXTRN ACCS + EXTRN OC + EXTRN PC +; +CR EQU 0DH +TAND EQU 80H +TOR EQU 84H +TERROR EQU 85H +TCALL EQU 0D6H +TDEF EQU 0DDH +; +;ASSEMBLER: +;LANGUAGE-INDEPENDENT CONTROL SECTION: +; Outputs: A=delimiter, carry set if syntax error. +; +ASSEM: CALL SKIP + INC IY + CP ':' + JR Z,ASSEM + CP ']' + RET Z + CP CR + RET Z + DEC IY + LD IX,(PC) ;PROGRAM COUNTER + LD HL,LISTON + BIT 6,(HL) + JR Z,ASSEM0 + LD IX,(OC) ;ORIGIN of CODE +ASSEM0: PUSH IX + PUSH IY + CALL ASMB + POP BC + POP DE + RET C + CALL SKIP + SCF + RET NZ + DEC IY +ASSEM3: INC IY + LD A,(IY) + CALL TERM0 + JR NZ,ASSEM3 + LD A,(LISTON) + PUSH IX + POP HL + OR A + SBC HL,DE + EX DE,HL ;DE= NO. OF BYTES + PUSH HL + LD HL,(PC) + PUSH HL + ADD HL,DE + LD (PC),HL ;UPDATE PC + BIT 6,A + JR Z,ASSEM5 + LD HL,(OC) + ADD HL,DE + LD (OC),HL ;UPDATE OC +ASSEM5: POP HL ;OLD PC + POP IX ;CODE HERE + BIT 4,A + JR Z,ASSEM + LD A,H + CALL HEX + LD A,L + CALL HEXSP + XOR A + CP E + JR Z,ASSEM2 +ASSEM1: LD A,(COUNT) + CP 17 + LD A,5 + CALL NC,TABIT ;NEXT LINE + LD A,(IX) + CALL HEXSP + INC IX + DEC E + JR NZ,ASSEM1 +ASSEM2: LD A,18 + CALL TABIT + PUSH IY + POP HL + SBC HL,BC +ASSEM4: LD A,(BC) + CALL OUT + INC BC + DEC L + JR NZ,ASSEM4 + CALL CRLF + JP ASSEM +; +HEXSP: CALL HEX + LD A,' ' + JR OUTCH1 +HEX: PUSH AF + RRCA + RRCA + RRCA + RRCA + CALL HEXOUT + POP AF +HEXOUT: AND 0FH + ADD A,90H + DAA + ADC A,40H + DAA +OUTCH1: JP OUT +; +;PROCESSOR-SPECIFIC TRANSLATION SECTION: +; +;REGISTER USAGE: B - TYPE OF MOST RECENT OPERAND +; C - OPCODE BEING BUILT +; D - (IX) OR (IY) FLAG +; E - OFFSET FROM IX OR IY +; HL - NUMERIC OPERAND VALUE +; IX - CODE DESTINATION +; IY - SOURCE TEXT POINTER +; Inputs: A = initial character +; Outputs: Carry set if syntax error. +; +ASMB: CP '.' + JR NZ,ASMB1 + INC IY + PUSH IX + CALL VAR + PUSH AF + CALL ZERO + EXX + LD HL,(PC) + EXX + LD A,(LISTON) + AND 20H + JR NZ,ASMB0 + LD A,(IX) + OR (IX+1) + LD A,3 + JP NZ,ERROR ;Multiple label +ASMB0: POP AF + CALL STOREN + POP IX +ASMB1: CALL SKIP + RET Z + CP TCALL + LD C,0C4H + INC IY + JP Z,GRPC + DEC IY + LD HL,OPCODS + CALL FIND + RET C + LD C,B ;ROOT OPCODE + LD D,0 ;CLEAR IX/IY FLAG +; +;GROUP 0 - TRIVIAL CASES REQUIRING NO COMPUTATION +;GROUP 1 - AS GROUP 0 BUT WITH "ED" PREFIX +; + SUB 39 + JR NC,GROUP2 + CP 15-39 + CALL NC,ED + JR BYTE0 +; +;GROUP 2 - BIT, RES, SET +;GROUP 3 - RLC, RRC, RL, RR, SLA, SRA, SRL +; +GROUP2: SUB 10 + JR NC,GROUP4 + CP 3-10 + CALL C,BIT + RET C + CALL REGLO + RET C + CALL CB + JR BYTE0 +; +;GROUP 4 - PUSH, POP, EX (SP) +; +GROUP4: SUB 3 + JR NC,GROUP5 +G4: CALL PAIR + RET C + JR BYTE0 +; +;GROUP 5 - SUB, AND, XOR, OR, CP +;GROUP 6 - ADD, ADC, SBC +; +GROUP5: SUB 8+2 + JR NC,GROUP7 + CP 5-8 + LD B,7 + CALL NC,OPND + LD A,B + CP 7 + JR NZ,G6HL +G6: CALL REGLO + LD A,C + JR NC,BIND1 + XOR 46H + CALL BIND +DB: CALL NUMBER + JR VAL8 +; +G6HL: AND 3FH + CP 12 + SCF + RET NZ + LD A,C + CP 80H + LD C,9 + JR Z,G4 + XOR 1CH + RRCA + LD C,A + CALL ED + JR G4 +; +;GROUP 7 - INC, DEC +; +GROUP7: SUB 2 + JR NC,GROUP8 + CALL REGHI + LD A,C +BIND1: JP NC,BIND + XOR 64H + RLCA + RLCA + RLCA + LD C,A + CALL PAIR1 + RET C +BYTE0: LD A,C + JR BYTE2 +; +;GROUP 8 - IN +;GROUP 9 - OUT +; +GROUP8: SUB 2 + JR NC,GROUPA + CP 1-2 + CALL Z,CORN + EX AF,AF' + CALL REGHI + RET C + EX AF,AF' + CALL C,CORN + INC H + JR Z,BYTE0 + LD A,B + CP 7 + SCF + RET NZ + LD A,C + XOR 3 + RLCA + RLCA + RLCA + CALL BYTE + JR VAL8 +; +;GROUP 10 - JR, DJNZ +; +GROUPA: SUB 2 + JR NC,GROUPB + CP 1-2 + CALL NZ,COND + LD A,C + JR NC,GRPA + LD A,18H +GRPA: CALL BYTE + CALL NUMBER + LD DE,(PC) + INC DE + SCF + SBC HL,DE + LD A,L + RLA + SBC A,A + CP H +TOOFAR: LD A,1 + JP NZ,ERROR ;"Out of range" +VAL8: LD A,L + JR BYTE2 +; +;GROUP 11 - JP +; +GROUPB: LD B,A + JR NZ,GROUPC + CALL COND + LD A,C + JR NC,GRPB + LD A,B + AND 3FH + CP 6 + LD A,0E9H + JR Z,BYTE2 + LD A,0C3H +GRPB: CALL BYTE + JR ADDR +; +;GROUP 12 - CALL +; +GROUPC: DJNZ GROUPD +GRPC: CALL GRPE +ADDR: CALL NUMBER +VAL16: CALL VAL8 + LD A,H + JR BYTE2 +; +;GROUP 13 - RST +; +GROUPD: DJNZ GROUPE + CALL NUMBER + AND C + OR H + JR NZ,TOOFAR + LD A,L + OR C +BYTE2: JR BYTE1 +; +;GROUP 14 - RET +; +GROUPE: DJNZ GROUPF +GRPE: CALL COND + LD A,C + JR NC,BYTE1 + OR 9 + JR BYTE1 +; +;GROUP 15 - LD +; +GROUPF: DJNZ MISC + CALL LDOP + JR NC,LDA + CALL REGHI + EX AF,AF' + CALL SKIP + CP '(' + JR Z,LDIN + EX AF,AF' + JP NC,G6 + LD C,1 + CALL PAIR1 + RET C + LD A,14 + CP B + LD B,A + CALL Z,PAIR + LD A,B + AND 3FH + CP 12 + LD A,C + JR NZ,GRPB + LD A,0F9H + JR BYTE1 +; +LDIN: EX AF,AF' + PUSH BC + CALL NC,REGLO + LD A,C + POP BC + JR NC,BIND + LD C,0AH + CALL PAIR1 + CALL LD16 + JR NC,GRPB + CALL NUMBER + LD C,2 + CALL PAIR + CALL LD16 + RET C + CALL BYTE + JR VAL16 +; +;OPT - SET OPTION +; +OPT: DEC B + JP Z,DB + DJNZ ADDR + CALL NUMBER + LD HL,LISTON + LD C,A + RLD + LD A,C + RRD + RET +; +LDA: CP 4 + CALL C,ED + LD A,B +BYTE1: JR BYTE +; +;MISC - DEFB, DEFW, DEFM +; +MISC: DJNZ OPT + PUSH IX + CALL EXPRS + POP IX + LD HL,ACCS +DEFM1: XOR A + CP E + RET Z + LD A,(HL) + INC HL + CALL BYTE + DEC E + JR DEFM1 +; +;SUBROUTINES: +; +LD16: LD A,B + JR C,LD8 + LD A,B + AND 3FH + CP 12 + LD A,C + RET Z + CALL ED + LD A,C + OR 43H + RET +; +LD8: CP 7 + SCF + RET NZ + LD A,C + OR 30H + RET +; +CORN: PUSH BC + CALL OPND + BIT 5,B + POP BC + JR Z,NUMBER + LD H,-1 +ED: LD A,0EDH + JR BYTE +; +CB: LD A,0CBH +BIND: CP 76H + SCF + RET Z ;REJECT LD (HL),(HL) + CALL BYTE + INC D + RET P + LD A,E + JR BYTE +; +OPND: PUSH HL + LD HL,OPRNDS + CALL FIND + POP HL + RET C + BIT 7,B + RET Z + BIT 3,B + PUSH HL + CALL Z,OFFSET + LD E,L + POP HL + LD A,0DDH + BIT 6,B + JR Z,OP1 + LD A,0FDH +OP1: OR A + INC D + LD D,A + RET M +BYTE: LD (IX),A + INC IX + OR A + RET +; +OFFSET: LD A,(IY) + CP ')' + LD HL,0 + RET Z +NUMBER: CALL SKIP + PUSH BC + PUSH DE + PUSH IX + CALL EXPRI + POP IX + EXX + POP DE + POP BC + LD A,L + OR A + RET +; +REG: CALL OPND + RET C + LD A,B + AND 3FH + CP 8 + CCF + RET +; +REGLO: CALL REG + RET C + JR ORC +; +REGHI: CALL REG + RET C + JR SHL3 +; +COND: CALL OPND + RET C + LD A,B + AND 1FH + SUB 16 + JR NC,SHL3 + CP -15 + SCF + RET NZ + LD A,3 + JR SHL3 +; +PAIR: CALL OPND + RET C +PAIR1: LD A,B + AND 0FH + SUB 8 + RET C + JR SHL3 +; +BIT: CALL NUMBER + CP 8 + CCF + RET C +SHL3: RLCA + RLCA + RLCA +ORC: OR C + LD C,A + RET +; +LDOP: LD HL,LDOPS +FIND: CALL SKIP +EXIT: LD B,0 + SCF + RET Z + CP TDEF + JR Z,FIND0 + CP TOR+1 + CCF + RET C +FIND0: LD A,(HL) + OR A + JR Z,EXIT + XOR (IY) + AND 01011111B + JR Z,FIND2 +FIND1: BIT 7,(HL) + INC HL + JR Z,FIND1 + INC HL + INC B + JR FIND0 +; +FIND2: PUSH IY +FIND3: BIT 7,(HL) + INC IY + INC HL + JR NZ,FIND5 + CP (HL) + CALL Z,SKIP0 + LD A,(HL) + XOR (IY) + AND 01011111B + JR Z,FIND3 +FIND4: POP IY + JR FIND1 +; +FIND5: CALL DELIM + CALL NZ,SIGN + JR NZ,FIND4 +FIND6: LD A,B + LD B,(HL) + POP HL + RET +; +SKIP0: INC HL +SKIP: CALL DELIM + RET NZ + CALL TERM + RET Z + INC IY + JR SKIP +; +SIGN: CP '+' + RET Z + CP '-' + RET +; +DELIM: LD A,(IY) ;ASSEMBLER DELIMITER + CP ' ' + RET Z + CP ',' + RET Z + CP ')' + RET Z +TERM: CP ';' ;ASSEMBLER TERMINATOR + RET Z + CP '\' + RET Z +TERM0: CP ':' ;ASSEMBLER SEPARATOR + RET NC + CP CR + RET +; +OPCODS: DEFM 'NO' + DEFB 'P'+80H + DEFB 0 + DEFM 'RLC' + DEFB 'A'+80H + DEFB 7 + DEFM 'EX' + DEFB 0 + DEFM 'AF' + DEFB 0 + DEFM 'AF' + DEFB ''''+80H + DEFB 8 + DEFM 'RRC' + DEFB 'A'+80H + DEFB 0FH + DEFM 'RL' + DEFB 'A'+80H + DEFB 17H + DEFM 'RR' + DEFB 'A'+80H + DEFB 1FH + DEFM 'DA' + DEFB 'A'+80H + DEFB 27H + DEFM 'CP' + DEFB 'L'+80H + DEFB 2FH + DEFM 'SC' + DEFB 'F'+80H + DEFB 37H + DEFM 'CC' + DEFB 'F'+80H + DEFB 3FH + DEFM 'HAL' + DEFB 'T'+80H + DEFB 76H + DEFM 'EX' + DEFB 'X'+80H + DEFB 0D9H + DEFM 'EX' + DEFB 0 + DEFM 'DE' + DEFB 0 + DEFM 'H' + DEFB 'L'+80H + DEFB 0EBH + DEFM 'D' + DEFB 'I'+80H + DEFB 0F3H + DEFM 'E' + DEFB 'I'+80H + DEFB 0FBH +; + DEFM 'NE' + DEFB 'G'+80H + DEFB 44H + DEFM 'IM' + DEFB 0 + DEFB '0'+80H + DEFB 46H + DEFM 'RET' + DEFB 'N'+80H + DEFB 45H + DEFM 'RET' + DEFB 'I'+80H + DEFB 4DH + DEFM 'IM' + DEFB 0 + DEFB '1'+80H + DEFB 56H + DEFM 'IM' + DEFB 0 + DEFB '2'+80H + DEFB 5EH + DEFM 'RR' + DEFB 'D'+80H + DEFB 67H + DEFM 'RL' + DEFB 'D'+80H + DEFB 6FH + DEFM 'LD' + DEFB 'I'+80H + DEFB 0A0H + DEFM 'CP' + DEFB 'I'+80H + DEFB 0A1H + DEFM 'IN' + DEFB 'I'+80H + DEFB 0A2H + DEFM 'OUT' + DEFB 'I'+80H + DEFB 0A3H + DEFM 'LD' + DEFB 'D'+80H + DEFB 0A8H + DEFM 'CP' + DEFB 'D'+80H + DEFB 0A9H + DEFM 'IN' + DEFB 'D'+80H + DEFB 0AAH + DEFM 'OUT' + DEFB 'D'+80H + DEFB 0ABH + DEFM 'LDI' + DEFB 'R'+80H + DEFB 0B0H + DEFM 'CPI' + DEFB 'R'+80H + DEFB 0B1H + DEFM 'INI' + DEFB 'R'+80H + DEFB 0B2H + DEFM 'OTI' + DEFB 'R'+80H + DEFB 0B3H + DEFM 'LDD' + DEFB 'R'+80H + DEFB 0B8H + DEFM 'CPD' + DEFB 'R'+80H + DEFB 0B9H + DEFM 'IND' + DEFB 'R'+80H + DEFB 0BAH + DEFM 'OTD' + DEFB 'R'+80H + DEFB 0BBH +; + DEFM 'BI' + DEFB 'T'+80H + DEFB 40H + DEFM 'RE' + DEFB 'S'+80H + DEFB 80H + DEFM 'SE' + DEFB 'T'+80H + DEFB 0C0H +; + DEFM 'RL' + DEFB 'C'+80H + DEFB 0 + DEFM 'RR' + DEFB 'C'+80H + DEFB 8 + DEFM 'R' + DEFB 'L'+80H + DEFB 10H + DEFM 'R' + DEFB 'R'+80H + DEFB 18H + DEFM 'SL' + DEFB 'A'+80H + DEFB 20H + DEFM 'SR' + DEFB 'A'+80H + DEFB 28H + DEFM 'SR' + DEFB 'L'+80H + DEFB 38H +; + DEFM 'PO' + DEFB 'P'+80H + DEFB 0C1H + DEFM 'PUS' + DEFB 'H'+80H + DEFB 0C5H + DEFM 'EX' + DEFB 0 + DEFM '(S' + DEFB 'P'+80H + DEFB 0E3H +; + DEFM 'SU' + DEFB 'B'+80H + DEFB 90H + DEFM 'AN' + DEFB 'D'+80H + DEFB 0A0H + DEFM 'XO' + DEFB 'R'+80H + DEFB 0A8H + DEFM 'O' + DEFB 'R'+80H + DEFB 0B0H + DEFM 'C' + DEFB 'P'+80H + DEFB 0B8H + DEFB TAND + DEFB 0A0H + DEFB TOR + DEFB 0B0H +; + DEFM 'AD' + DEFB 'D'+80H + DEFB 80H + DEFM 'AD' + DEFB 'C'+80H + DEFB 88H + DEFM 'SB' + DEFB 'C'+80H + DEFB 98H +; + DEFM 'IN' + DEFB 'C'+80H + DEFB 4 + DEFM 'DE' + DEFB 'C'+80H + DEFB 5 +; + DEFM 'I' + DEFB 'N'+80H + DEFB 40H + DEFM 'OU' + DEFB 'T'+80H + DEFB 41H +; + DEFM 'J' + DEFB 'R'+80H + DEFB 20H + DEFM 'DJN' + DEFB 'Z'+80H + DEFB 10H +; + DEFM 'J' + DEFB 'P'+80H + DEFB 0C2H +; + DEFM 'CAL' + DEFB 'L'+80H + DEFB 0C4H +; + DEFM 'RS' + DEFB 'T'+80H + DEFB 0C7H +; + DEFM 'RE' + DEFB 'T'+80H + DEFB 0C0H +; + DEFM 'L' + DEFB 'D'+80H + DEFB 40H +; + DEFB TDEF AND 7FH + DEFB 'M'+80H + DEFB 0 +; + DEFB TDEF AND 7FH + DEFB 'B'+80H + DEFB 0 +; + DEFM 'OP' + DEFB 'T'+80H + DEFB 0 +; + DEFB TDEF AND 7FH + DEFB 'W'+80H + DEFB 0 +; + DEFB 0 +; +OPRNDS: DEFB 'B'+80H + DEFB 0 + DEFB 'C'+80H + DEFB 1 + DEFB 'D'+80H + DEFB 2 + DEFB 'E'+80H + DEFB 3 + DEFB 'H'+80H + DEFB 4 + DEFB 'L'+80H + DEFB 5 + DEFM '(H' + DEFB 'L'+80H + DEFB 6 + DEFB 'A'+80H + DEFB 7 + DEFM '(I' + DEFB 'X'+80H + DEFB 86H + DEFM '(I' + DEFB 'Y'+80H + DEFB 0C6H +; + DEFM 'B' + DEFB 'C'+80H + DEFB 8 + DEFM 'D' + DEFB 'E'+80H + DEFB 10 + DEFM 'H' + DEFB 'L'+80H + DEFB 12 + DEFM 'I' + DEFB 'X'+80H + DEFB 8CH + DEFM 'I' + DEFB 'Y'+80H + DEFB 0CCH + DEFM 'A' + DEFB 'F'+80H + DEFB 14 + DEFM 'S' + DEFB 'P'+80H + DEFB 14 +; + DEFM 'N' + DEFB 'Z'+80H + DEFB 16 + DEFB 'Z'+80H + DEFB 17 + DEFM 'N' + DEFB 'C'+80H + DEFB 18 + DEFM 'P' + DEFB 'O'+80H + DEFB 20 + DEFM 'P' + DEFB 'E'+80H + DEFB 21 + DEFB 'P'+80H + DEFB 22 + DEFB 'M'+80H + DEFB 23 +; + DEFM '(' + DEFB 'C'+80H + DEFB 20H +; + DEFB 0 +; +LDOPS: DEFM 'I' + DEFB 0 + DEFB 'A'+80H + DEFB 47H + DEFM 'R' + DEFB 0 + DEFB 'A'+80H + DEFB 4FH + DEFM 'A' + DEFB 0 + DEFB 'I'+80H + DEFB 57H + DEFM 'A' + DEFB 0 + DEFB 'R'+80H + DEFB 5FH + DEFM '(BC' + DEFB 0 + DEFB 'A'+80H + DEFB 2 + DEFM '(DE' + DEFB 0 + DEFB 'A'+80H + DEFB 12H + DEFM 'A' + DEFB 0 + DEFM '(B' + DEFB 'C'+80H + DEFB 0AH + DEFM 'A' + DEFB 0 + DEFM '(D' + DEFB 'E'+80H + DEFB 1AH +; + DEFB 0 +; +FIN: END diff --git a/Source/Images/Common/UTILS/BBCBASIC.TXT b/Source/Apps/BBCBASIC/bbcbasic.txt similarity index 81% rename from Source/Images/Common/UTILS/BBCBASIC.TXT rename to Source/Apps/BBCBASIC/bbcbasic.txt index 84a28f89..0fa96f2e 100644 --- a/Source/Images/Common/UTILS/BBCBASIC.TXT +++ b/Source/Apps/BBCBASIC/bbcbasic.txt @@ -1,3 +1,20 @@ +This is a RomWBW HBIOS adaptation of BBCBASIC v5.00. The +cursor and screen management assumes the use of an ANSI/VT-100 terminal +which is generally correct for RomWBW. Support for a hardware system +timer is also implemented. If your system does not have a hardware +timer, the TIME function will always return 0 and the timeout +parameter of the INKEY(n) function will not be observed (will never +timeout). + +What follows is some basic information on BBCBASIC from the +distribution. Note that it starts with the v3.00 information and +later on provides information on the changes in v5.00. + +-- WBW 1:15 PM 5/30/2024 + + + + BBC BASIC (Z80) Generic CP/M Version 3.00 @@ -366,4 +383,73 @@ 198 Disk full 254 Bad command 200 Close error 255 CP/M error 204 Bad name - \ No newline at end of file + + +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. \ No newline at end of file diff --git a/Source/Apps/BBCBASIC/cmos.z80 b/Source/Apps/BBCBASIC/cmos.z80 new file mode 100644 index 00000000..c76ce6c3 --- /dev/null +++ b/Source/Apps/BBCBASIC/cmos.z80 @@ -0,0 +1,1494 @@ + TITLE BBC BASIC (C) R.T.RUSSELL 1984-2024 + NAME ('CMOS') +; +;PATCH FOR BBC BASIC TO CP/M 2.2 & 3.0 +;* PLAIN VANILLA CP/M VERSION * +;(C) COPYRIGHT R.T.RUSSELL, 25-12-1986 +;VERSION 5.0, 25-05-2024 +; + GLOBAL OSINIT + GLOBAL OSRDCH + GLOBAL OSWRCH + GLOBAL OSLINE + GLOBAL OSSAVE + GLOBAL OSLOAD + GLOBAL OSOPEN + GLOBAL OSSHUT + GLOBAL OSBGET + GLOBAL OSBPUT + GLOBAL OSSTAT + GLOBAL GETEXT + GLOBAL GETPTR + GLOBAL PUTPTR + GLOBAL PROMPT + GLOBAL RESET + GLOBAL LTRAP + GLOBAL OSCLI + GLOBAL TRAP + GLOBAL OSKEY + GLOBAL OSCALL +; + EXTRN BYE + EXTRN GETKEY +; + EXTRN ESCAPE + EXTRN EXTERR + EXTRN CHECK + EXTRN CRLF +; + EXTRN ACCS + EXTRN FREE + EXTRN HIMEM + EXTRN CURLIN + EXTRN USER + EXTRN VERMSG +; +; +;OSSAVE - Save an area of memory to a file. +; Inputs: HL addresses filename (term CR) +; DE = start address of data to save +; BC = length of data to save (bytes) +; Destroys: A,B,C,D,E,H,L,F +; +STSAVE: CALL SAVLOD ;*SAVE + JP C,HUH ;"Bad command" + PUSH HL + JR OSS1 +; +OSSAVE: PUSH BC ;SAVE + CALL SETUP0 +OSS1: EX DE,HL + CALL CREATE + JR NZ,SAVE +DIRFUL: LD A,190 + CALL EXTERR + DEFM 'Directory full' + DEFB 0 +SAVE: CALL WRITE + ADD HL,BC + EX (SP),HL + SBC HL,BC + EX (SP),HL + JR Z,SAVE1 + JR NC,SAVE +SAVE1: POP BC +CLOSE: LD A,16 + CALL BDOS1 + INC A + RET NZ + LD A,200 + CALL EXTERR + DEFM 'Close error' + DEFB 0 +; +;OSSHUT - Close disk file(s). +; Inputs: E = file channel +; If E=0 all files are closed (except SPOOL) +; Destroys: A,B,C,D,E,H,L,F +; +OSSHUT: LD A,E + OR A + JR NZ,SHUTIT +SHUT0: INC E + BIT 3,E + RET NZ + PUSH DE + CALL SHUT1 + POP DE + JR SHUT0 +; +SHUTIT: CALL FIND1 + JR NZ,SHUT2 + JP CHANER +; +SESHUT: LD HL,FLAGS + RES 0,(HL) ;STOP EXEC + RES 1,(HL) ;STOP SPOOL + LD E,8 ;SPOOL/EXEC CHANNEL +SHUT1: CALL FIND1 + RET Z +SHUT2: XOR A + LD (HL),A + DEC HL + LD (HL),A + LD HL,37 + ADD HL,DE + BIT 7,(HL) + INC HL + CALL NZ,WRITE + LD HL,FCBSIZ + ADD HL,DE + LD BC,(FREE) + SBC HL,BC + JR NZ,CLOSE + LD (FREE),DE ;RELEASE SPACE + JR CLOSE +; +;TYPE - *TYPE command. +;Types file to console output. +; +TYPE: SCF ;*TYPE + CALL OSOPEN + OR A + JR Z,NOTFND + LD E,A +TYPE1: LD A,(FLAGS) ;TEST + BIT 7,A ;FOR + JR NZ,TYPESC ;ESCape + CALL OSBGET + CALL OSWRCH ;N.B. CALLS "TEST" + JR NC,TYPE1 + JR OSSHUT +; +TYPESC: CALL OSSHUT ;CLOSE! + JP ABORT +; +;OSLOAD - Load an area of memory from a file. +; Inputs: HL addresses filename (term CR) +; DE = address at which to load +; BC = maximum allowed size (bytes) +; Outputs: Carry reset indicates no room for file. +; Destroys: A,B,C,D,E,H,L,F +; +STLOAD: CALL SAVLOD ;*LOAD + PUSH HL + JR OSL1 +; +OSLOAD: PUSH BC ;LOAD + CALL SETUP0 +OSL1: EX DE,HL + CALL OPEN + JR NZ,LOAD0 +NOTFND: LD A,214 + CALL EXTERR + DEFM 'File not found' + DEFB 0 +LOAD: CALL READ + JR NZ,LOAD1 + CALL INCSEC + ADD HL,BC +LOAD0: EX (SP),HL + SBC HL,BC + EX (SP),HL + JR NC,LOAD +LOAD1: POP BC + PUSH AF + CALL CLOSE + POP AF + CCF +OSCALL: RET +; +;OSOPEN - Open a file for reading or writing. +; Inputs: HL addresses filename (term CR) +; Carry set for OPENIN, cleared for OPENOUT. +; Outputs: A = file channel (=0 if cannot open) +; DE = file FCB +; Destroys: A,B,C,D,E,H,L,F +; +OPENIT: PUSH AF ;SAVE CARRY + CALL SETUP0 + POP AF + CALL NC,CREATE + CALL C,OPEN + RET +; +OSOPEN: CALL OPENIT + RET Z ;ERROR + LD B,7 ;MAX. NUMBER OF FILES + LD HL,TABLE+15 +OPEN1: LD A,(HL) + DEC HL + OR (HL) + JR Z,OPEN2 ;FREE CHANNEL + DEC HL + DJNZ OPEN1 + LD A,192 + CALL EXTERR + DEFM 'Too many open files' + DEFB 0 +; +OPEN2: LD DE,(FREE) ;FREE SPACE POINTER + LD (HL),E + INC HL + LD (HL),D + LD A,B ;CHANNEL (1-7) + LD HL,FCBSIZ + ADD HL,DE ;RESERVE SPACE + LD (FREE),HL +OPEN3: LD HL,FCB ;ENTRY FROM SPOOL/EXEC + PUSH DE + LD BC,36 + LDIR ;COPY FCB + EX DE,HL + INC HL + LD (HL),C ;CLEAR PTR + INC HL + POP DE + LD B,A + CALL RDF ;READ OR FILL + LD A,B + JP CHECK +; +;OSBPUT - Write a byte to a random disk file. +; Inputs: E = file channel +; A = byte to write +; Destroys: A,B,C,F +; +OSBPUT: PUSH DE + PUSH HL + LD B,A + CALL FIND + LD A,B + LD B,0 + DEC HL + LD (HL),B ;CLEAR EOF + INC HL + LD C,(HL) + RES 7,C + SET 7,(HL) + INC (HL) + INC HL + PUSH HL + ADD HL,BC + LD (HL),A + POP HL + CALL Z,WRRDF ;WRITE THEN READ/FILL + POP HL + POP DE + RET +; +;OSBGET - Read a byte from a random disk file. +; Inputs: E = file channel +; Outputs: A = byte read +; Carry set if LAST BYTE of file +; Destroys: A,B,C,F +; +OSBGET: PUSH DE + PUSH HL + CALL FIND + LD C,(HL) + RES 7,C + INC (HL) + INC HL + PUSH HL + LD B,0 + ADD HL,BC + LD B,(HL) + POP HL + CALL PE,INCRDF ;INC SECTOR THEN READ + CALL Z,WRRDF ;WRITE THEN READ/FILL + LD A,B + POP HL + POP DE + RET +; +;OSSTAT - Read file status. +; Inputs: E = file channel +; Outputs: Z flag set - EOF +; (If Z then A=0) +; DE = address of file block. +; Destroys: A,D,E,H,L,F +; +OSSTAT: CALL FIND + DEC HL + LD A,(HL) + INC A + RET +; +;GETEXT - Find file size. +; Inputs: E = file channel +; Outputs: DEHL = file size (0-&800000) +; Destroys: A,B,C,D,E,H,L,F +; +GETEXT: CALL FIND + EX DE,HL + LD DE,FCB + LD BC,36 + PUSH DE + LDIR ;COPY FCB + EX DE,HL + EX (SP),HL + EX DE,HL + LD A,35 + CALL BDOS1 ;COMPUTE SIZE + POP HL + XOR A + JR GETPT1 +; +;GETPTR - Return file pointer. +; Inputs: E = file channel +; Outputs: DEHL = pointer (0-&7FFFFF) +; Destroys: A,B,C,D,E,H,L,F +; +GETPTR: CALL FIND + LD A,(HL) + ADD A,A + DEC HL +GETPT1: DEC HL + LD D,(HL) + DEC HL + LD E,(HL) + DEC HL + LD H,(HL) + LD L,A + SRL D + RR E + RR H + RR L + RET +; +;PUTPTR - Update file pointer. +; Inputs: A = file channel +; DEHL = new pointer (0-&7FFFFF) +; Destroys: A,B,C,D,E,H,L,F +; +PUTPTR: LD D,L + ADD HL,HL + RL E + LD B,E + LD C,H + LD E,A ;CHANNEL + PUSH DE + CALL FIND + POP AF + AND 7FH + BIT 7,(HL) ;PENDING WRITE? + JR Z,PUTPT1 + OR 80H +PUTPT1: LD (HL),A + PUSH DE + PUSH HL + DEC HL + DEC HL + DEC HL + LD D,(HL) + DEC HL + LD E,(HL) + EX DE,HL + OR A + SBC HL,BC + POP HL + POP DE + RET Z + INC HL + OR A + CALL M,WRITE + PUSH HL + DEC HL + DEC HL + DEC HL + LD (HL),0 + DEC HL + LD (HL),B + DEC HL + LD (HL),C ;NEW RECORD NO. + POP HL + JR RDF +; +;WRRDF - Write, read; if EOF fill with zeroes. +;RDF - Read; if EOF fill with zeroes. +; Inputs: DE address FCB. +; HL addresses data buffer. +; Outputs: A=0, Z-flag set. +; Carry set if fill done (EOF) +; Destroys: A,H,L,F +; +WRRDF: CALL WRITE +RDF: CALL READ + DEC HL + RES 7,(HL) + DEC HL + LD (HL),A ;CLEAR EOF FLAG + RET Z + LD (HL),-1 ;SET EOF FLAG + INC HL + INC HL + PUSH BC + XOR A + LD B,128 +FILL: LD (HL),A + INC HL + DJNZ FILL + POP BC + SCF + RET +; +;INCRDF - Increment record, read; if EOF fill. +; Inputs: DE addresses FCB. +; HL addresses data buffer. +; Outputs: A=1, Z-flag reset. +; Carry set if fill done (EOF) +; Destroys: A,H,L,F +; +INCRDF: CALL INCSEC + CALL RDF + INC A + RET +; +;READ - Read a record from a disk file. +; Inputs: DE addresses FCB. +; HL = address to store data. +; Outputs: A<>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/Source/Apps/BBCBASIC/data.z80 b/Source/Apps/BBCBASIC/data.z80 new file mode 100644 index 00000000..a8e1a2c3 --- /dev/null +++ b/Source/Apps/BBCBASIC/data.z80 @@ -0,0 +1,69 @@ + TITLE BBC BASIC (C) R.T.RUSSELL 1981-2024 + NAME ('DATA') +; +;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/Source/Images/Common/UTILS/BBCDIST.MAC b/Source/Apps/BBCBASIC/dist.z80 similarity index 55% rename from Source/Images/Common/UTILS/BBCDIST.MAC rename to Source/Apps/BBCBASIC/dist.z80 index 6df1c9a6..abfb5560 100644 --- a/Source/Images/Common/UTILS/BBCDIST.MAC +++ b/Source/Apps/BBCBASIC/dist.z80 @@ -1,7 +1,8 @@ - TITLE BBCDIST.Z80 (C) R.T.RUSSELL 1982 + TITLE BBCDIST.Z80 (C) R.T.RUSSELL 1982-2024 + NAME ('DIST3') ; -;BBC BASIC (Z80) - CP/M VERSION 2.30 & 3.00 -;(C) COPYRIGHT R.T.RUSSELL, 1982. +;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 @@ -13,11 +14,14 @@ ;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 -;ALTERNATE REGISTERS SAVED FOR BDOS CALL, 04-06-2000 +;R.T.RUSSELL, 11-03-1984, 03-05-1989, 12-05-2024 ; CPM EQU 5 COLD EQU 200H +; +CR EQU 0DH +LF EQU 0AH +ESC EQU 1BH ; GLOBAL CLRSCN GLOBAL PUTCSR @@ -26,14 +30,18 @@ COLD EQU 200H GLOBAL GETIME GLOBAL GETKEY GLOBAL BYE + GLOBAL BEGIN +; GLOBAL BDOS +; +; EXTRN PRTDEC16 ; - ASEG - ORG 100H + ;ASEG + ;ORG 100H ; ;JUMP TABLE - BASIC makes calls to hardware-dependent ;features via this table: ; - JP INIT +BEGIN: JP INIT CLRSCN: JP CLS ;CLEAR SCREEN PUTCSR: JP PCSR ;SET CURSOR POSN. GETCSR: JP GCSR ;READ CURSOR POSN. @@ -42,30 +50,33 @@ GETIME: JP GTIME ;READ ELAPSED TIME GETKEY: JP INKEY ;READ KEY (TIME LIMIT) BYE: JP REBOOT ;RETURN TO CP/M ; -;THE CODE WHICH FOLLOWS IS A SKELETON VERSION SUITABLE -;FOR ANY CP/M SYSTEM. IT HAS BEEN CONFIGURED FOR A VT100 TO SOME DEGREE -;BY PETER SCHORN. +;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 ; - -PRSTR EQU 9 - ;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,PRSTR +INIT: LD HL,40H ;CPM/HBIOS MARKER LOC + LD A,'W' + CP (HL) + JR NZ,FAIL + INC HL + LD A,NOT 'W' + CP (HL) + JR NZ,FAIL + JP COLD +FAIL: LD DE,NOTHB + LD C,9 CALL BDOS RST 0 ; -NOTZ80: DEFB 'Wrong processor$' -NOTV2: DEFB 'Wrong CP/M version$' +NOTHB: DEFB 'CP/M w/ HBIOS required$' ; ;REBOOT - Switch off interrupts and return to CP/M ; @@ -75,31 +86,34 @@ REBOOT: RST 0 ; Outputs: DEHL = elapsed time (centiseconds) ; Destroys: A,D,E,H,L,F ; -GTIME: LD DE,0 - LD HL,0 - RET +GTIME: JR TICKS ; ;PTIME - Load elapsed-time clock. ; Inputs: DEHL = time to load (centiseconds) ; Destroys: A,D,E,H,L,F ; -PTIME: RET +PTIME: + LD BC,0F9D0H + SRL D + RR E + RR H + RR L + RST 08 + RET ; -;CLS - Clear screen for VT100. -; Destroys: A,D,E,H,L,F +; Get OS elapsed-time clock +; Outputs: DEHL = time (centiseconds) +; Destroys: A,B,C,D,E,H,L,F ; -CLS: PUSH BC ; save BC - LD C,PRSTR ; command for output string - LD DE,CLSSTR ; start address of string - CALL BDOS ; output to terminal - POP BC ; restore BC +TICKS: LD BC,0F8D0H + RST 08 + SLA L + RL H + RL E + RL D RET -CLSSTR: DEFB 27,'[2J$' ; VT100 string for clear screen - ; ;INKEY - Sample keyboard with specified wait. -; This version uses a simple software timing loop. -; Modify to use hardware/interrupt timer if available. ; Inputs: HL = Time to wait (centiseconds) ; Outputs: Carry reset indicates time-out. ; If carry set, A = character typed. @@ -107,52 +121,64 @@ CLSSTR: DEFB 27,'[2J$' ; VT100 string for clear screen ; INKEY: PUSH BC PUSH HL + CALL TICKS + POP DE + ADD HL,DE +WAIT: PUSH HL LD C,6 LD E,0FFH - CALL BDOS ;CONSOLE INPUT + CALL BDOS POP HL - POP BC OR A SCF - RET NZ ;KEY PRESSED - OR H - OR L - RET Z ;TIME-OUT - PUSH BC - LD A,-1 - LD BC,1250 ;DELAY CONSTANT -WAIT: DEC BC - CP B - JP NZ,WAIT ;WAIT FOR APPROX 10ms - POP BC - DEC HL - JR INKEY + 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: + LD DE,CLSSTR + LD C,9 + JP BDOS +; +CLSSTR: DEFB ESC,'[H',ESC,'[2J$' ; ;PCSR - Move cursor to specified position. ; Inputs: DE = horizontal position (LHS=0) ; HL = vertical position (TOP=0) -; called by TAB(column, row) +; Destroys: A,D,E,H,L,F +; PCSR: LD B,L ; vertical = line (row) CALL CONV ; normalized and convert to decimal LD (LIN),HL ; and store into string LD B,E ; horizontal = column CALL CONV ; normalized and convert to decimal LD (COL),HL ; and store into string - LD C,PRSTR ; output string command + LD C,9 ; output string command LD DE,CURS ; start of string - JR BDOS ; output string to terminal - + JP BDOS ; output string to terminal +; ; VT100 sequence for cursor positioning CURS: DEFB 27, '[' LIN: DEFW 0 ; high byte, low byte for decimal line DEFB ';' COL: DEFW 0 ; high byte, low byte for decimal column DEFB 'H$' - +; ; convert binary B (0 <= B < 99, not checked) into B+1 in decimal. ; L = upper byte, H = lower byte. ready for LD (...), HL ; destroys A, B, L, H ; optimized for space over time +; CONV: INC B ; normalize, home in VT100 is (1,1) LD A,'0' ; A is counter for low byte of result LD L,A ; L is counter for high byte of result @@ -164,35 +190,7 @@ CONVLP: INC A ; now B times increment AL in decimal CONT: DJNZ CONVLP ; B times LD H,A ; put low byte into right place RET - - -;BDOS - Save the IX and IY and alternate registers -; before performing a CP/M function call. ; -BDOS: PUSH IX - PUSH IY - EXX - PUSH BC - PUSH DE - PUSH HL - EXX - EX AF,AF' - PUSH AF - EX AF,AF' - CALL CPM - EX AF,AF' - POP AF - EX AF,AF' - EXX - POP HL - POP DE - POP BC - EXX - POP IY - POP IX - RET - - ;GCSR - Return cursor coordinates. ; Outputs: DE = X coordinate (POS) ; HL = Y coordinate (VPOS) @@ -202,24 +200,42 @@ GCSR: LD DE,0 LD HL,0 RET ; - IF $ GT 1F4H +;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 + IF $-BEGIN GT 0F0H ERROR 'INSUFFICIENT SPACE' ENDIF ; - ORG 1F4H + ;ORG 1F0H + DEFS 0F0H - ($ - BEGIN) ; +OFFLO: DEFW 0 ;TIME OFFSET LO +OFFHI: DEFW 0 ;TIME OFFSET HI DEFB 80 ;WIDTH - DEFB 'E' AND 1FH ;CURSOR UP - DEFB 'X' AND 1FH ;CURSOR DOWN - DEFB 'A' AND 1FH ;START OF LINE - DEFB 'F' AND 1FH ;END OF LINE - DEFB 'T' AND 1FH ;DELETE TO END OF LINE - DEFB 'H' AND 1FH ;BACKSPACE - DEFB 'U' AND 1FH ;CANCEL LINE - DEFB 'S' AND 1FH ;CURSOR LEFT - DEFB 'D' AND 1FH ;CURSOR RIGHT - DEFB 'G' AND 1FH ;DELETE CHARACTER - DEFB 'V' AND 1FH ;INSERT CHARACTER + 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 - \ No newline at end of file diff --git a/Source/Apps/BBCBASIC/eval.z80 b/Source/Apps/BBCBASIC/eval.z80 new file mode 100644 index 00000000..0e445df3 --- /dev/null +++ b/Source/Apps/BBCBASIC/eval.z80 @@ -0,0 +1,2587 @@ + TITLE BBC BASIC (C) R.T.RUSSELL 1981-2024 + NAME ('EVAL') +; +;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/Source/Apps/BBCBASIC/exec.z80 b/Source/Apps/BBCBASIC/exec.z80 new file mode 100644 index 00000000..17e647da --- /dev/null +++ b/Source/Apps/BBCBASIC/exec.z80 @@ -0,0 +1,3274 @@ + TITLE BBC BASIC (C) R.T.RUSSELL 1981-2024 + NAME ('EXEC') +; +;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/Source/Apps/BBCBASIC/hook.z80 b/Source/Apps/BBCBASIC/hook.z80 new file mode 100644 index 00000000..f5619647 --- /dev/null +++ b/Source/Apps/BBCBASIC/hook.z80 @@ -0,0 +1,64 @@ + NAME ('HOOK') +; + 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/Source/Apps/BBCBASIC/main.z80 b/Source/Apps/BBCBASIC/main.z80 new file mode 100644 index 00000000..5d947378 --- /dev/null +++ b/Source/Apps/BBCBASIC/main.z80 @@ -0,0 +1,2237 @@ + TITLE BBC BASIC (C) R.T.RUSSELL 1981-2024 + NAME ('MAIN') +; +;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/Source/Apps/BBCBASIC/math.z80 b/Source/Apps/BBCBASIC/math.z80 new file mode 100644 index 00000000..5a3ba8c3 --- /dev/null +++ b/Source/Apps/BBCBASIC/math.z80 @@ -0,0 +1,2267 @@ + TITLE '(C) COPYRIGHT R.T.RUSSELL 1986-2024' + NAME ('MATH') +; +;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/Source/Apps/Build.cmd b/Source/Apps/Build.cmd index 0776541e..2da8d667 100644 --- a/Source/Apps/Build.cmd +++ b/Source/Apps/Build.cmd @@ -30,6 +30,7 @@ pushd VGM && call Build || exit /b & popd pushd cpuspd && call Build || exit /b & popd pushd Survey && call Build || exit /b & popd pushd HTalk && call Build || exit /b & popd +pushd BBCBASIC && call Build || exit /b & popd copy *.com %APPBIN%\ || exit /b diff --git a/Source/Apps/Clean.cmd b/Source/Apps/Clean.cmd index 06057f1f..c95fdad7 100644 --- a/Source/Apps/Clean.cmd +++ b/Source/Apps/Clean.cmd @@ -19,3 +19,4 @@ pushd VGM && call Clean || exit /b 1 & popd pushd cpuspd && call Clean || exit /b 1 & popd pushd Survey && call Clean || exit /b 1 & popd pushd HTalk && call Clean || exit /b 1 & popd +pushd BBCBASIC && call Clean || exit /b 1 & popd diff --git a/Source/Apps/Makefile b/Source/Apps/Makefile index a3ae67fe..39ed301b 100644 --- a/Source/Apps/Makefile +++ b/Source/Apps/Makefile @@ -1,6 +1,6 @@ OBJECTS = sysgen.com syscopy.com assign.com format.com talk.com \ mode.com rtc.com timer.com rtchb.com -SUBDIRS = HTalk XM FDU FAT Tune Test ZMP ZMD Dev VGM cpuspd Survey +SUBDIRS = HTalk XM FDU FAT Tune Test ZMP ZMD Dev VGM cpuspd Survey BBCBASIC DEST = ../../Binary/Apps TOOLS =../../Tools diff --git a/Source/Images/Common/UTILS/BBCBASIC.COM b/Source/Images/Common/UTILS/BBCBASIC.COM deleted file mode 100644 index f7496f6b..00000000 Binary files a/Source/Images/Common/UTILS/BBCBASIC.COM and /dev/null differ diff --git a/Source/Images/Common/UTILS/BBCDIST.SUB b/Source/Images/Common/UTILS/BBCDIST.SUB deleted file mode 100644 index d438ba7b..00000000 --- a/Source/Images/Common/UTILS/BBCDIST.SUB +++ /dev/null @@ -1,13 +0,0 @@ -; patch BBCBASIC with BBCDIST -; need M80 and L80 -xsub -m80 =bbcdist/z -l80 bbcdist,bbcdist/n/e -ddt bbcbasic.org -ibbcdist.com -r -g0 -save 58 bbcbasic.com -era bbcdist.rel -era bbcdist.com - \ No newline at end of file diff --git a/Source/Images/hd_bp.txt b/Source/Images/hd_bp.txt index e551906a..58f88d7e 100644 --- a/Source/Images/hd_bp.txt +++ b/Source/Images/hd_bp.txt @@ -11,6 +11,8 @@ # #../../Binary/Apps/*.com 15: ../../Binary/Apps/assign.com 15: +../../Binary/Apps/bbcbasic.com 0: +../../Binary/Apps/bbcbasic.txt 0: ../../Binary/Apps/cpuspd.com 15: ../../Binary/Apps/fat.com 15: ../../Binary/Apps/fdu.com 15: diff --git a/Source/Images/hd_cpm22.txt b/Source/Images/hd_cpm22.txt index 22f43a66..a2f7f94e 100644 --- a/Source/Images/hd_cpm22.txt +++ b/Source/Images/hd_cpm22.txt @@ -7,6 +7,8 @@ d_cpm22/ReadMe.txt 0: # #../../Binary/Apps/*.com 0: ../../Binary/Apps/assign.com 0: +../../Binary/Apps/bbcbasic.com 0: +../../Binary/Apps/bbcbasic.txt 0: ../../Binary/Apps/cpuspd.com 0: ../../Binary/Apps/fat.com 0: ../../Binary/Apps/fdu.com 0: diff --git a/Source/Images/hd_cpm3.txt b/Source/Images/hd_cpm3.txt index 60baad02..ba8383bd 100644 --- a/Source/Images/hd_cpm3.txt +++ b/Source/Images/hd_cpm3.txt @@ -23,6 +23,8 @@ # #../../Binary/Apps/*.com 0: ../../Binary/Apps/assign.com 0: +../../Binary/Apps/bbcbasic.com 0: +../../Binary/Apps/bbcbasic.txt 0: ../../Binary/Apps/cpuspd.com 0: ../../Binary/Apps/fat.com 0: ../../Binary/Apps/fdu.com 0: diff --git a/Source/Images/hd_nzcom.txt b/Source/Images/hd_nzcom.txt index 6305b6ca..bdcdad1c 100644 --- a/Source/Images/hd_nzcom.txt +++ b/Source/Images/hd_nzcom.txt @@ -24,6 +24,8 @@ d_zsdos/u0/*.* 0: # #../../Binary/Apps/*.com 0: ../../Binary/Apps/assign.com 0: +../../Binary/Apps/bbcbasic.com 0: +../../Binary/Apps/bbcbasic.txt 0: ../../Binary/Apps/cpuspd.com 0: ../../Binary/Apps/fat.com 0: ../../Binary/Apps/fdu.com 0: diff --git a/Source/Images/hd_qpm.txt b/Source/Images/hd_qpm.txt index 90fbce7c..f8fc8e85 100644 --- a/Source/Images/hd_qpm.txt +++ b/Source/Images/hd_qpm.txt @@ -11,6 +11,8 @@ d_cpm22/u0/*.* 0: # #../../Binary/Apps/*.com 0: ../../Binary/Apps/assign.com 0: +../../Binary/Apps/bbcbasic.com 0: +../../Binary/Apps/bbcbasic.txt 0: ../../Binary/Apps/cpuspd.com 0: ../../Binary/Apps/fat.com 0: ../../Binary/Apps/fdu.com 0: diff --git a/Source/Images/hd_zpm3.txt b/Source/Images/hd_zpm3.txt index 1417a6fc..1532cb55 100644 --- a/Source/Images/hd_zpm3.txt +++ b/Source/Images/hd_zpm3.txt @@ -22,6 +22,8 @@ # #../../Binary/Apps/*.com 15: ../../Binary/Apps/assign.com 15: +../../Binary/Apps/bbcbasic.com 0: +../../Binary/Apps/bbcbasic.txt 0: ../../Binary/Apps/cpuspd.com 15: ../../Binary/Apps/fat.com 15: ../../Binary/Apps/fdu.com 15: diff --git a/Source/Images/hd_zsdos.txt b/Source/Images/hd_zsdos.txt index 2a2ddea2..9dc1dcda 100644 --- a/Source/Images/hd_zsdos.txt +++ b/Source/Images/hd_zsdos.txt @@ -20,6 +20,8 @@ d_cpm22/u0/XSUB.COM 0: # #../../Binary/Apps/*.com 0: ../../Binary/Apps/assign.com 0: +../../Binary/Apps/bbcbasic.com 0: +../../Binary/Apps/bbcbasic.txt 0: ../../Binary/Apps/cpuspd.com 0: ../../Binary/Apps/fat.com 0: ../../Binary/Apps/fdu.com 0: diff --git a/Source/ver.inc b/Source/ver.inc index 4db182b9..0b8f3f40 100644 --- a/Source/ver.inc +++ b/Source/ver.inc @@ -2,7 +2,7 @@ #DEFINE RMN 5 #DEFINE RUP 0 #DEFINE RTP 0 -#DEFINE BIOSVER "3.5.0-dev.43" +#DEFINE BIOSVER "3.5.0-dev.44" #define rmj RMJ #define rmn RMN #define rup RUP diff --git a/Source/ver.lib b/Source/ver.lib index fbd7857d..e1e22fee 100644 --- a/Source/ver.lib +++ b/Source/ver.lib @@ -3,5 +3,5 @@ rmn equ 5 rup equ 0 rtp equ 0 biosver macro - db "3.5.0-dev.43" + db "3.5.0-dev.44" endm