From ad7d7638d3d020a47c99f35e3ad3b1a3c19fac04 Mon Sep 17 00:00:00 2001 From: Wayne Warthen Date: Mon, 17 Feb 2025 17:21:44 -0800 Subject: [PATCH] Update BBC BASIC - Updated BBC BASIC (Z80) source from R.T.Russell's repository. --- Source/Apps/BBCBASIC/bbcbasic.txt | 251 +- Source/Apps/BBCBASIC/cmos.z80 | 2995 ++++++------- Source/Apps/BBCBASIC/eval.z80 | 5178 +++++++++++------------ Source/Apps/BBCBASIC/exec.z80 | 6568 +++++++++++++++-------------- Source/Apps/BBCBASIC/hook.z80 | 132 +- Source/Apps/BBCBASIC/licence.txt | 19 + Source/Apps/BBCBASIC/main.z80 | 4473 ++++++++++---------- Source/Apps/BBCBASIC/math.z80 | 4519 ++++++++++---------- Source/Doc/Applications.md | 112 +- 9 files changed, 12202 insertions(+), 12045 deletions(-) create mode 100644 Source/Apps/BBCBASIC/licence.txt diff --git a/Source/Apps/BBCBASIC/bbcbasic.txt b/Source/Apps/BBCBASIC/bbcbasic.txt index 0fa96f2e..f8d1dc16 100644 --- a/Source/Apps/BBCBASIC/bbcbasic.txt +++ b/Source/Apps/BBCBASIC/bbcbasic.txt @@ -1,16 +1,21 @@ -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 +This is a RomWBW HBIOS adaptation of BBCBASIC v5.00 by R.T.Russell. +This implementation was adapted from the source code found at +https://github.com/rtrussell/BBCZ80. + +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. +later on provides information on the changes in v5.00. Complete +documentation for the BBC BASIC (Z80) is found online at +https://www.bbcbasic.co.uk/bbcbasic/mancpm/index.html. --- WBW 1:15 PM 5/30/2024 +-- WBW 4:21 PM 2/17/2025 @@ -23,55 +28,55 @@ later on provides information on the changes in v5.00. 1. INTRODUCTION - BBC BASIC (Z80) has been designed to be as compatible as possible with - Version 4 of the 6502 BBC BASIC resident in the BBC Micro Master series. - The language syntax is not always identical to that of the 6502 version, + BBC BASIC (Z80) has been designed to be as compatible as possible with + Version 4 of the 6502 BBC BASIC resident in the BBC Micro Master series. + The language syntax is not always identical to that of the 6502 version, but in most cases the Z80 version is more tolerant. - BBC BASIC (Z80) is as machine independent as possible and, as supplied, - it will run on any CP/M 2.2 (or later) system using a Z80 processor - (checks are carried out to ensure that the processor is a Z80 and that - the version of CP/M is at least 2.2). It is minimally configured for an + BBC BASIC (Z80) is as machine independent as possible and, as supplied, + it will run on any CP/M 2.2 (or later) system using a Z80 processor + (checks are carried out to ensure that the processor is a Z80 and that + the version of CP/M is at least 2.2). It is minimally configured for an ADM3a-compatible VDU. - Few CP/M systems offer colour graphics of the quality provided as - standard on the BBC Microcomputer, and no software can provide colour - high-resolution graphics from a monochrome character-orientated computer. - However, many CP/M system users are interested in the advanced program - structures available from BBC BASIC and, within the limitations of the - host computer, BBC BASIC (Z80) provides the programming structures and + Few CP/M systems offer colour graphics of the quality provided as + standard on the BBC Microcomputer, and no software can provide colour + high-resolution graphics from a monochrome character-orientated computer. + However, many CP/M system users are interested in the advanced program + structures available from BBC BASIC and, within the limitations of the + host computer, BBC BASIC (Z80) provides the programming structures and the non-graphic commands and functions specified for BBC BASIC. - In order to make full use of the facilities available in BBC BASIC (Z80) - it is necessary to install a small patch to adapt it to the capabilities - of the host computer. The source code of the patch present in the + In order to make full use of the facilities available in BBC BASIC (Z80) + it is necessary to install a small patch to adapt it to the capabilities + of the host computer. The source code of the patch present in the distribution version is supplied as BBCDIST.MAC. - This documentation should be read in conjunction with a standard BBC - BASIC manual. Only those features which differ from the standard Acorn + This documentation should be read in conjunction with a standard BBC + BASIC manual. Only those features which differ from the standard Acorn versions are documented here. 2. MEMORY UTILISATION - BBC BASIC (Z80) requires about 16 Kbytes of code space, resulting in a - value of PAGE of about &3E00. The remainder of the user memory is - available for BASIC programs, variables (heap) and stack. Depending on + BBC BASIC (Z80) requires about 16 Kbytes of code space, resulting in a + value of PAGE of about &3E00. The remainder of the user memory is + available for BASIC programs, variables (heap) and stack. Depending on the system configuration, HIMEM can have a value up to &FE00. 3. COMMANDS, STATEMENTS AND FUNCTIONS - The syntax of BASIC commands, statements and functions is in most cases - identical to that of the BBC Micro version (BASIC 4). The few + The syntax of BASIC commands, statements and functions is in most cases + identical to that of the BBC Micro version (BASIC 4). The few differences are documented here: ADVAL This function is not implemented. CALL - CALL sets up a table in RAM containing details of the parameters; the - processor's IX register is set to the address of this parameter table. + CALL sets up a table in RAM containing details of the parameters; the + processor's IX register is set to the address of this parameter table. The other processor registers are initialised as follows: A is initialised to the least significant byte of A% @@ -92,7 +97,7 @@ later on provides information on the changes in v5.00. 128 Fixed string $A% 129 Movable string A$ - On entry to the subroutine the parameter table contains the following + On entry to the subroutine the parameter table contains the following values: Number of parameters 1 byte (at IX) @@ -103,29 +108,29 @@ later on provides information on the changes in v5.00. Parameter type ) repeated as often as necessary Parameter address ) - Except in the case of a movable string (normal string variable), the - parameter address given is the absolute address at which the item is - stored. In the case of movable strings (type 129) it is the address of a - 4-byte parameter block containing the current length, the maximum length + Except in the case of a movable string (normal string variable), the + parameter address given is the absolute address at which the item is + stored. In the case of movable strings (type 129) it is the address of a + 4-byte parameter block containing the current length, the maximum length and the start address of the string (LSB first) in that order. - Integer variables are stored in twos complement form with their least + Integer variables are stored in twos complement form with their least significant byte first. - Fixed strings are stored as the characters of the string followed by a + Fixed strings are stored as the characters of the string followed by a carriage return (&0D). - Floating point variables are stored in binary floating point format with - their least significant byte first; the fifth byte is the exponent. The - mantissa is stored as a binary fraction in sign and magnitude format. - Bit 7 of the most significant byte is the sign bit and, for the purposes - of calculating the magnitude of the number, this bit is assumed to be set - to one. The exponent is stored as an integer in excess 127 format (to + Floating point variables are stored in binary floating point format with + their least significant byte first; the fifth byte is the exponent. The + mantissa is stored as a binary fraction in sign and magnitude format. + Bit 7 of the most significant byte is the sign bit and, for the purposes + of calculating the magnitude of the number, this bit is assumed to be set + to one. The exponent is stored as an integer in excess 127 format (to find the exponent subtract 127 from the value in the fifth byte). - If the exponent byte of a floating point number is zero, the number is an - integer stored in integer format in the mantissa bytes. Thus an integer - can be represented in two different ways in a real variable. For example + If the exponent byte of a floating point number is zero, the number is an + integer stored in integer format in the mantissa bytes. Thus an integer + can be represented in two different ways in a real variable. For example the value +5 can be stored as: 05 00 00 00 00 Integer 5 @@ -138,15 +143,15 @@ later on provides information on the changes in v5.00. This statement is not implemented. EDIT - A command to edit or concatenate and edit the specified program line(s). - The specified lines (including their line numbers) are listed as a single - line. By changing only the line number you can use EDIT to duplicate a + A command to edit or concatenate and edit the specified program line(s). + The specified lines (including their line numbers) are listed as a single + line. By changing only the line number you can use EDIT to duplicate a line. EDIT 230 EDIT 200,230 - The following control functions are active both in the EDIT mode and in + The following control functions are active both in the EDIT mode and in the immediate entry mode (i.e. at the BASIC prompt): Move the cursor one character position to the left @@ -159,8 +164,8 @@ later on provides information on the changes in v5.00. Delete all characters to the left of the cursor Delete all characters from the cursor to the end of the line - The choice of which keys activate these functions is made when BBC BASIC - is configured for a particular system. The distribution version uses ^H, + The choice of which keys activate these functions is made when BBC BASIC + is configured for a particular system. The distribution version uses ^H, ^I, ^K, ^J, ^A, ^E, DEL (&7F), ^L and ^X. To exit EDIT mode and replace the edited line, type RETURN (ENTER). @@ -171,28 +176,28 @@ later on provides information on the changes in v5.00. This statement is not implemented. GET - This function waits for a character to be typed at the keyboard, and + This function waits for a character to be typed at the keyboard, and returns the ASCII code. - GET can also be used to read data from a processor I/O port; full 16-bit + GET can also be used to read data from a processor I/O port; full 16-bit port addressing is available: N% = GET(X%) : REM input from port X% INKEY - This function waits for a specified maximum number of centiseconds for a - character to be typed at the keyboard. If no character is typed in that - time, the value -1 is returned. In the distribution version the delay is - determined by a simple software timing loop, and may be very inaccurate. - The customisation patch allows this to be adjusted to suit the system in + This function waits for a specified maximum number of centiseconds for a + character to be typed at the keyboard. If no character is typed in that + time, the value -1 is returned. In the distribution version the delay is + determined by a simple software timing loop, and may be very inaccurate. + The customisation patch allows this to be adjusted to suit the system in use. INPUT# - The format of data files is different from that used by the BBC Micro, in - part to improve compatibility with standard CP/M files. Numeric values - are stored as five bytes in the format documented under CALL; if the - fifth byte is zero the value is an integer. Strings are stored as the - characters of the string (in the correct order!) followed by a carriage + The format of data files is different from that used by the BBC Micro, in + part to improve compatibility with standard CP/M files. Numeric values + are stored as five bytes in the format documented under CALL; if the + fifth byte is zero the value is an integer. Strings are stored as the + characters of the string (in the correct order!) followed by a carriage return (&0D). MODE @@ -208,15 +213,15 @@ later on provides information on the changes in v5.00. This function is not implemented. PRINT# - The format of data files is different from that used by the BBC Micro, in - part to improve compatibility with standard CP/M files. Numeric values - are stored as five bytes in the format documented under CALL; if the - fifth byte is zero the value is an integer. Strings are stored as the - characters of the string (in the correct order!) followed by a carriage + The format of data files is different from that used by the BBC Micro, in + part to improve compatibility with standard CP/M files. Numeric values + are stored as five bytes in the format documented under CALL; if the + fifth byte is zero the value is an integer. Strings are stored as the + characters of the string (in the correct order!) followed by a carriage return (&0D). PUT - A statement to output data to a processor port. Full 16-bit addressing + A statement to output data to a processor port. Full 16-bit addressing is available. PUT A%,N% : REM Output N% to port A% @@ -225,7 +230,7 @@ later on provides information on the changes in v5.00. This statement is not implemented. TIME - This pseudo-variable is not implemented in the distribution version, but + This pseudo-variable is not implemented in the distribution version, but can be supported by means of the customisation patch. See BBCDIST.MAC. USR @@ -240,34 +245,34 @@ later on provides information on the changes in v5.00. H is initialised to the least significant byte of H% L is initialised to the least significant byte of L% - USR returns a 32-bit integer result composed of the processor's H, L, H' + USR returns a 32-bit integer result composed of the processor's H, L, H' and L' registers, with H being the most significant. 4. RESIDENT Z80 ASSEMBLER - The in-line assembler is accessed in exactly the same way as the 6502 - assembler in the BBC Micro version of BBC BASIC. That is, '[' enters + The in-line assembler is accessed in exactly the same way as the 6502 + assembler in the BBC Micro version of BBC BASIC. That is, '[' enters assembler mode and ']' exits assembler mode. - All standard Zilog mnemonics are accepted: ADD, ADC and SBC must be - followed by A or HL. For example, ADD A,C is accepted but ADD C is not. - However, the brackets around the port number in IN and OUT are optional. - Thus both OUT (5),A and OUT 5,A are accepted. The instruction IN F,(C) + All standard Zilog mnemonics are accepted: ADD, ADC and SBC must be + followed by A or HL. For example, ADD A,C is accepted but ADD C is not. + However, the brackets around the port number in IN and OUT are optional. + Thus both OUT (5),A and OUT 5,A are accepted. The instruction IN F,(C) is not accepted, but the equivalent code is produced from IN (HL),C - The pseudo-ops DEFB, DEFW and DEFM are included. DEFM works like EQUS in + The pseudo-ops DEFB, DEFW and DEFM are included. DEFM works like EQUS in the 6502 version. 5. OPERATING SYSTEM INTERFACE - The following resident Operating System ("star") commands are - implemented. They may be accessed directly (e.g. *BYE) or via the OSCLI + The following resident Operating System ("star") commands are + implemented. They may be accessed directly (e.g. *BYE) or via the OSCLI statement (OSCLI "BYE"). - Control characters, lower-case characters, DEL and quotation marks may be - incorporated in filenames by using the 'escape' character '|'. However, + Control characters, lower-case characters, DEL and quotation marks may be + incorporated in filenames by using the 'escape' character '|'. However, there is no equivalent to the BBC Microcomputer's '|!' to set bit 7. *BYE @@ -278,7 +283,7 @@ later on provides information on the changes in v5.00. *. [filespec] *DIR [filespec] - List the files which match the (optional) ambiguous filespec. If the + List the files which match the (optional) ambiguous filespec. If the filespec is omitted, all .BBC files are listed: *DIR List all .BBC files on the disk *DIR B:*.* List all files on disk B: @@ -288,53 +293,53 @@ later on provides information on the changes in v5.00. Select drive d as the default drive for subsequent disk operations. *ERA filespec - Erase (delete) the specified disk file or files. The extension defaults + Erase (delete) the specified disk file or files. The extension defaults to .BBC if omitted. *ESC [ON|OFF] - *ESC OFF disables the abort action of the ESCape key; after *ESC OFF the - ESCape key simply returns the ASCII code ESC (27). *ESC ON, or *ESC, + *ESC OFF disables the abort action of the ESCape key; after *ESC OFF the + ESCape key simply returns the ASCII code ESC (27). *ESC ON, or *ESC, restores the normal action of the ESCape key. *EXEC filespec - Accept console input from the specified file instead of from the + Accept console input from the specified file instead of from the keyboard. If the extension is omitted, .BBC is assumed. *LOAD filespec aaaa - Loads the specified file into memory at address aaaa. The load address + Loads the specified file into memory at address aaaa. The load address must be specified. If the extension is omitted, .BBC is assumed. *OPT [n] - Select the destination for console output characters. The value n is in + Select the destination for console output characters. The value n is in the range 0 to 2, as follows: - + 0 Send characters to the console output 1 Send characters to the auxiliary output 2 Send characters to the printer (list) output *REN newfile=oldfile *RENAME newfile=oldfile - Renames 'oldfile' as 'newfile'. If the extension is omitted, .BBC is + Renames 'oldfile' as 'newfile'. If the extension is omitted, .BBC is assumed. *RESET - Rest the disk system (CP/M function 13). This command does not close any - files nor does it perform any other housekeeping function. You should + Rest the disk system (CP/M function 13). This command does not close any + files nor does it perform any other housekeeping function. You should use *RESET after you have changed a disk. *SAVE filespec aaaa bbbb *SAVE filespec aaaa +llll - This command saves a specified range of memory to disk. The address range - is specified either as start (aaaa) and end+1 (bbbb) or as start (aaaa) + This command saves a specified range of memory to disk. The address range + is specified either as start (aaaa) and end+1 (bbbb) or as start (aaaa) and length (llll). If the extension is omitted, .BBC is assumed. *SPOOL [filespec] - Copy all subsequent console output to the specified file. If the filename - is omitted, any current spool file is closed and spooling is terminated. + Copy all subsequent console output to the specified file. If the filename + is omitted, any current spool file is closed and spooling is terminated. If the extension is omitted, .BBC is assumed. *TYPE filespec - Type the specified file to the screen. If the extension is omitted, .BBC + Type the specified file to the screen. If the extension is omitted, .BBC is assumed. *| comment @@ -352,7 +357,7 @@ later on provides information on the changes in v5.00. Trappable - BASIC: 1 Out of range 24 Exp range - 2 25 + 2 25 3 26 No such variable 4 Mistake 27 Missing ) 5 Missing , 28 Bad HEX @@ -383,9 +388,9 @@ later on provides information on the changes in v5.00. 198 Disk full 254 Bad command 200 Close error 255 CP/M error 204 Bad name - -New features in BBC BASIC (Z80) version 5.00, May 2024: + +New features in BBC BASIC (Z80) version 5.00, January 2025: 1. BASIC V statements @@ -394,7 +399,7 @@ New features in BBC BASIC (Z80) version 5.00, May 2024: 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.6 DIM var LOCAL size 1.7 ERROR err, message$ 1.8 RESTORE +n 1.9 SWAP var1,var2 @@ -408,10 +413,10 @@ New features in BBC BASIC (Z80) version 5.00, May 2024: 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 +2.6 MOD(array()) +2.7 SUM(array()) +2.8 SUMLEN(array()) +2.9 GET$#file 3. BASIC V whole array operations @@ -423,9 +428,12 @@ New features in BBC BASIC (Z80) version 5.00, May 2024: 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) + +3.9 DIM a LOCAL array (on the stack) + + +* String array expressions are not currently supported, instead of using + a$() = b$() + c$() use a$() = b$() : a$() += c$() + The use of EVAL with whole-array expressions is not currently supported. -* 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$() = "" @@ -434,22 +442,27 @@ New features in BBC BASIC (Z80) version 5.00, May 2024: 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 +4.3 Additional VDU delimiter '|' +4.4 RETURNed parameters from FN/PROC +4.5 Compound assignment (+=, -=, *=, /= etc.) +4.6 Assigning to a sub-string: LEFT$()=, MID$()= , RIGHT$()= +4.7 Hooks for CIRCLE, ELLIPSE, FILL, LINE, ORIGIN, RECTANGLE (graphics) +4.8 Hooks for MOUSE, OFF, ON, SYS, TINT, WAIT (statements) +4.9 Hooks for MODE function, TINT function, WIDTH 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.2 Address-of operator (^) +5.3 Byte (unsigned 8-bit) 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) +5.8 DIM var LOCAL -1 returns the stack pointer, even outside a FN/PROC +5.9 RESTORE LOCAL restores local variables without exiting the FN/PROC 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 +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 index c76ce6c3..151aa55f 100644 --- a/Source/Apps/BBCBASIC/cmos.z80 +++ b/Source/Apps/BBCBASIC/cmos.z80 @@ -1,1494 +1,1501 @@ - 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 + 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 AUTONO + 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 + CALL EXTERR + DEFM 'CP/M Error' + DEFB 0 +; +BDOS0: PUSH BC + PUSH DE + PUSH HL + PUSH IX + PUSH IY + LD C,A + CALL BDOS + INC H + DEC H + 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 BC,0 + 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 'P' AND 1FH + JP Z,TOGGLE + 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-8) ;END OF LINE (IX-8) + JP Z,RIGHT + CP (IX-7) ;CLEAR RIGHT (IX-7) + JR Z,DELETE + LD C,0 ;INHIBIT REPEAT + 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 + XOR A + LD L,A + LD (EDPTR),HL + LD DE,(CURLIN) + CP D + RET NZ + CP E + RET NZ + LD DE,(AUTONO) + 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/eval.z80 b/Source/Apps/BBCBASIC/eval.z80 index 0e445df3..6dc82500 100644 --- a/Source/Apps/BBCBASIC/eval.z80 +++ b/Source/Apps/BBCBASIC/eval.z80 @@ -1,2587 +1,2591 @@ - 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 + TITLE BBC BASIC (C) R.T.RUSSELL 1981-2025 + NAME ('EVAL') +; +;BBC BASIC INTERPRETER - Z80 VERSION +;EVALUATE EXPRESSION MODULE - "EVAL" +;(C) COPYRIGHT R.T.RUSSELL 1981-2025 +; +;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, 31-05-2024 +;VERSION 5.1, 28-12-2024 +;VERSION 5.2, 11-01-2025 +; +;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 +; +EXPR45: LD A,E + CP '+' + JR Z,EXPR4 + CP '-' + JR Z,EXPR4 +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 +; +BADHEX: LD A,28 +ERROR2: JP ERROR ;"Bad HEX or binary" +; +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 +; +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' + JR ERROR0 +; +; 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 +REPDUN: LD A,80H ;STRING MARKER + RET Z + LD B,0 + LDIR + RET +; +LOADS2: PUSH IX + POP HL +LOADS3: LD A,(HL) + LD (DE),A + INC HL + CP CR + JR Z,REPDUN + INC E + JR NZ,LOADS3 + 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 + BIT 1,B + JR Z,GET10 + 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: OR A +GET10: LD (HL),A + INC L + DEC D + JR C,GET9 ;EOF + 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 +; +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 +; +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 )" +; +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 + SBC HL,HL + ADD HL,SP ;HL = SP + SBC HL,BC + JR C,ERROR1 ;'No room' + PUSH BC + LD BC,(FREE) + INC B ;Safety margin + SBC HL,BC + ADD HL,BC + POP BC + JR C,ERROR1 ;'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 ;Operator + 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: D = type +; E = operator ('=' for first item) +; BC = number of elements +; HL = pointer to destination on stack +; IY = text pointer +; Outputs: IY updated +; Destroys: Everything except SP +; +ITEMA: CALL NXT + PUSH HL ;Pointer to destination + PUSH BC ;Number of elements + PUSH IY ;In case normal expression + PUSH DE ;Ditto + 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 DE ;Type and operator + CALL GETVAR + POP DE ;Type & operator + JR NZ,ITEMA4 ;Non-array expression + BIT 6,A + JR Z,ITEMA4 ;Not a whole array + POP BC ;Junk saved original op + POP BC ;Junk saved text pointer + 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 DE ;Restore original operator + POP IY ;Restore original text pointer + BIT 7,D + JR NZ,ITEMA5 + PUSH DE + CALL EXPR45 ;; 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 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 DE + EX DE,HL + CALL X14OR5 + EX DE,HL + POP DE + 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 + CALL X14OR5 + 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 D,B + LD E,C + CALL X14OR5 + 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 index 17e647da..66639e6f 100644 --- a/Source/Apps/BBCBASIC/exec.z80 +++ b/Source/Apps/BBCBASIC/exec.z80 @@ -1,3274 +1,3294 @@ - 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 + TITLE BBC BASIC (C) R.T.RUSSELL 1981-2025 + NAME ('EXEC') +; +;BBC BASIC INTERPRETER - Z80 VERSION +;STATEMENT EXECUTION MODULE - "EXEC" +;(C) COPYRIGHT R.T.RUSSELL 1981-2025 +; +;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, 12-07-2024 +;VERSION 5.1, 28-12-2024 +;VERSION 5.2, 11-01-2025 +;VERSION 5.3, 31-01-2025 +; + 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 CSRON + EXTRN CSROFF +; + 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 ELLIPS + 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 ELLIPS + 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 +; +EXTRAS: CP TELSE-TCMD + JR Z,REM ;ELSE + CP TERROR-TCMD + JR Z,THROW ;ERROR + CP TLINE-TCMD + JP Z,LINE ;LINE + CP TOFF-TCMD + JP Z,CSROFF ;OFF + JP SYNTAX +; +;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 +; +;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 XEQGO4 +; +;[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 + PUSH DE + PUSH HL + CALL EXPRS + POP IX + POP HL + CALL MODIFS +XEQGO4: 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 XEQGO4 +; +;= +; +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 + SBC HL,DE + OR A + SBC HL,BC + ADD HL,SP + JR Z,ARRCHK ;RESERVE NOTHING + 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: CALL TERMQ + JP Z,CSRON + 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 ;'ON range' + DEFB 21H +FORVAR: LD A,34 ;'FOR variable' +ERROR2: JP ERROR +; +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] +; +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 +XEQGO6: 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 + JR Z,XEQGO6 ;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 + JR NZ,NENDIF +XEQGO7: JP XEQ +; +; WHEN and OTHERWISE: +; +WHEN: LD BC,-3 + ADD IY,BC + LD BC,TENDCASE + LD DE,TENDCASE*256+TOF + CALL NSCAN + JR Z,XEQGO7 + 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,XEQGO5 + LD H,0 + LD L,C + ADD HL,SP + LD SP,HL + JR XEQGO5 +; +;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 + JR XEQGO5 +; +;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 + JR XEQGO5 +; +;CLEAR +; +CLR: CALL CLEAR + LD HL,(PAGE) + JR RESTR1 +; +;RESTORE DATA / ERROR / LOCAL +; +RESDEL: INC IY ;Skip DATA / ERROR / LOCAL + LD A,C ;Save error code + EX AF,AF' + LD A,B ;1=DATA, 2=ERROR, 0=LOCAL + CALL RESLOC + JR NZ,XEQGO5 + EX AF,AF' ;Get error code + DEFB 21H +NOLINE: LD A,41 ;'No such line' +ERROR5: JP ERROR +; +;RESTORE [line | +n | DATA | ERROR | LOCAL] +; +RESTOR: CP TERROR + LD BC,200H + 53 ;'ON ERROR not LOCAL' + JR Z,RESDEL + CP TDATA + LD BC,100H + 54 ;'DATA not LOCAL' + JR Z,RESDEL + CP TLOCAL + LD BC,12 ;'Not in a FN or PROC' + JR Z,RESDEL + 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 + LD B,1 +VDU1: CALL OSWRCH + DJNZ VDU1 + LD A,(IY) + CP '|' + JR Z,VDU4 + CP ',' + JR Z,VDU2 + CP ';' + JR NZ,VDU3 + LD A,H + CALL OSWRCH +VDU2: INC IY +VDU3: CALL TERMQ + JR NZ,VDU + JR XEQGO1 +; +VDU4: INC IY + XOR A + LD B,9 + JR VDU1 +; +;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 +BPUT1: CALL OSBPUT +BPUTX: JR XEQGO1 +; +BPUTS: LD A,E + POP DE + LD D,A + LD HL,ACCS + OR A + JR Z,BPUTS0 +BPUTS1: LD A,(HL) + INC HL + CALL OSBPUT + DEC D + JR NZ,BPUTS1 +BPUTS0: CALL NXT + CP ';' + LD A,LF + JR NZ,BPUT1 + INC 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 + JR C,ERRORC +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 IX + EX (SP),IY + CALL PUSHS + PUSH IY + POP IX + CALL LOADS + POP BC + LD A,E + ADD C + LD A,19 ;String too long +ERRORC: JR C,ERROR6 + 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 +ERROR6: 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 + INC IX ;Flag something restored + 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 index f5619647..ba991ec8 100644 --- a/Source/Apps/BBCBASIC/hook.z80 +++ b/Source/Apps/BBCBASIC/hook.z80 @@ -1,64 +1,68 @@ - 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 + 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 ELLIPS + GLOBAL FILL + GLOBAL MOUSE + GLOBAL ORIGIN + GLOBAL RECTAN + GLOBAL LINE + GLOBAL TINT + GLOBAL WAIT + GLOBAL SYS + GLOBAL CSRON + GLOBAL CSROFF +; + 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: +ELLIPS: +FILL: +MOUSE: +ORIGIN: +RECTAN: +LINE: +TINT: +TINTFN: +MODEFN: +WIDFN: +WAIT: +SYS: +CSRON: +CSROFF: + XOR A + CALL EXTERR + DEFM 'Sorry' + DEFB 0 +; + END diff --git a/Source/Apps/BBCBASIC/licence.txt b/Source/Apps/BBCBASIC/licence.txt new file mode 100644 index 00000000..d7c9c3f0 --- /dev/null +++ b/Source/Apps/BBCBASIC/licence.txt @@ -0,0 +1,19 @@ +Copyright (c) 2024, Richard T. Russell, http://www.rtrussell.co.uk/ + +This software is provided 'as-is', without any express or implied +warranty. In no event will the authors be held liable for any damages +arising from the use of this software. + +Permission is granted to anyone to use this software for any purpose, +including commercial applications, and to alter it and redistribute it +freely, subject to the following restrictions: + +1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software + in a product, an acknowledgment in the product documentation would be + appreciated but is not required. + +2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + +3. This notice may not be removed or altered from any source distribution. diff --git a/Source/Apps/BBCBASIC/main.z80 b/Source/Apps/BBCBASIC/main.z80 index 5d947378..740ff400 100644 --- a/Source/Apps/BBCBASIC/main.z80 +++ b/Source/Apps/BBCBASIC/main.z80 @@ -1,2237 +1,2236 @@ - 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 + TITLE BBC BASIC (C) R.T.RUSSELL 1981-2025 + NAME ('MAIN') +; +;BBC BASIC INTERPRETER - Z80 VERSION +;COMMANDS AND COMMON MODULE - "MAIN" +;(C) COPYRIGHT R.T.RUSSELL 1981-2025 +; +;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, 31-05-2024 +;VERSION 5.1, 10-08-2024 +;VERSION 5.2, 16-02-2025 +; + 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 5.00 ' + DEFB CR + DEFB LF +NOTICE: DEFM '(C) Copyright R.T.Russell 2025' + 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 A,H + OR L + JR NZ,INAUTO + LD B,A + 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 +; +INAUTO: LD IY,ACCS +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 0D8H + DEFM 'CLEAR ' + DEFB 0D9H + DEFM 'CLOSE ' + DEFB 0DAH + DEFM 'CLG ' + DEFB 0DBH + DEFM 'CLS ' + DEFB 9BH + DEFM 'COS' + DEFB 9CH + DEFM 'COUNT ' + DEFB 01H + DEFM 'CIRCLE' ; v5 + 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 0E1H + DEFM 'ENDPROC ' + DEFB 0CEH + DEFM 'ENDWHILE ' ; v5 + DEFB 0CBH + DEFM 'ENDCASE ' ; v5 + DEFB 0CDH + DEFM 'ENDIF ' ; 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 82H + DEFM 'EOR' + DEFB 9FH + DEFM 'ERR ' + DEFB 10H + DEFM 'EXIT ' ; v5 + DEFB 0A1H + DEFM 'EXP' + DEFB 0A2H + DEFM 'EXT ' + DEFB 02H + DEFM 'ELLIPSE' ; v5 + 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 0A8H + DEFM 'INT' + DEFB 0A7H + DEFM 'INSTR(' + DEFB 0CH + DEFM 'INSTALL' ; v5 + 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 0ECH + DEFM 'MOVE' + DEFB 04H + DEFM 'MOUSE' ; v5 + DEFB 0EDH + DEFM 'NEXT' + DEFB 0ACH + DEFM 'NOT' + DEFB 0EEH + DEFM 'ON' + DEFB 87H + DEFM 'OFF ' + DEFB 0CAH + DEFM 'OF ' ; v5 + DEFB 05H + DEFM 'ORIGIN' ; v5 + DEFB 84H + DEFM 'OR' + DEFB 8EH + DEFM 'OPENIN' + DEFB 0AEH + DEFM 'OPENOUT' + DEFB 0ADH + DEFM 'OPENUP' + DEFB 0FFH + DEFM 'OSCLI' + DEFB 0CCH + DEFM 'OTHERWISE' ; v5 + 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 0F2H + DEFM 'PROC' + DEFB 0B1H + DEFM 'POS ' + DEFB 0EH + DEFM 'PUT' ; Token changed + 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 8AH + DEFM 'TAB(' + DEFB 8CH + DEFM 'THEN' + DEFB 91H + DEFM 'TIME ' + DEFB 0AH + DEFM 'TINT' + DEFB 0B8H + DEFM 'TO' + DEFB 0FCH + DEFM 'TRACE' + 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 0C7H + DEFM 'WHILE' ; v5 + DEFB 0C9H + DEFM 'WHEN' ; v5 + DEFB 0BH + DEFM 'WAIT ' ; v5 + DEFB 0FEH + DEFM 'WIDTH' +;'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 + JR Z,WARMNC + 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 + 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 + JP ERROR ;'No room' (A = 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 + JR Z,WARMNC + 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 +; +;LOAD filename +; +LOAD: CALL EXPRS ;GET FILENAME + LD A,CR + LD (DE),A + CALL LOAD0 + CALL CLEAR + JR WARM0 +; +;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 +; +;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 + JR CLOOP0 +; +;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 +; +INDSUB: DEC E + JP P,INDRET +INDADD: 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 C + CP '&'+1 + CCF + RET NC + 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 TDATA + JR Z,LEXAN9 + CP TOKLO + JR C,LEXAN8 + CP TOKHI+1 + JR NC,LEXAN8 + ADD A,OFFSET ;LEFT VERSION +LEXAN8: CP TREM + 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 index 5a3ba8c3..d37951b0 100644 --- a/Source/Apps/BBCBASIC/math.z80 +++ b/Source/Apps/BBCBASIC/math.z80 @@ -1,2267 +1,2252 @@ - 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 + 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, 16-06-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 + CALL SLA8 + 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 + INC C + EXX + RL C + RL B + CALL SLA8 + CALL SLA8 + 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 +; +SLA8: EXX + SLA E + RL D + EXX + RL E + RL D + EXX + ADC HL,HL + EXX + ADC HL,HL + 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/Doc/Applications.md b/Source/Doc/Applications.md index cecf0b4d..1b0a71b0 100644 --- a/Source/Doc/Applications.md +++ b/Source/Doc/Applications.md @@ -1000,11 +1000,12 @@ binary executable applications are found in the Binary/Apps directory. The table below clarifies where each of the applications may be found. It is not an exhaustive list, with further applications existing on both the ROM-based and disk-based versions of CP/M. All of the Applications -incuded within RomWBW may be found with in the Binary/Apps directory. +included within RomWBW may be found within the Binary/Apps directory. | Application | ROM Disk | Boot Disks | | ----------- | :------: | :--------: | | ASSIGN | Yes | Yes | +| BBCBASIC | No | Yes | | CLRDIR | Yes | Yes | | COPYSL | No | Yes | | CPUSPD | Yes | Yes | @@ -1020,14 +1021,17 @@ incuded within RomWBW may be found with in the Binary/Apps directory. | SURVEY | Yes | Yes | | SYSCOPY | Yes | Yes | | TALK | Yes | Yes | +| TBASIC | No | Yes | | TIMER | Yes | Yes | | TUNE | No | Yes | | VGMPLAY | No | Yes | | WDATE | No | Yes | | XM | Yes | Yes | +| ZMD | No | Yes | +| ZMP | No | Yes | All of the CP/M applications may be found in the RomWBW Binary/Apps directory -and a user may copy those they need to their own customised disk/slice. +and a user may copy those they need to their own customized disk/slice. Independently of whether the CP/M system was started from ROM or a boot disk, such as a floppy disk or a slice on a CF or uSD memory card, applications @@ -1280,6 +1284,30 @@ sure to use `ASSIGN` prior to loading the RSX or after it is unloaded. The `ASSIGN` command is an original product and the source code is provided in the RomWBW distribution. +`\clearpage`{=latex} + +## BBCBASIC + +| BBCBASIC | | +| --------------------|---| +| ROM-based |No | +| Disk-based |Yes| + +#### Syntax + +#### Usage + +#### Notes + +#### Etymology + + + + + + + + `\clearpage`{=latex} ## CLRDIR @@ -2232,6 +2260,30 @@ operating systems such as CP/M 3 is not supported. The `TALK` command is an original product and the source code is provided in the RomWBW distribution. +`\clearpage`{=latex} + +## TBASIC + +| TBASIC | | +| --------------------|---| +| ROM-based |No | +| Disk-based |Yes| + +#### Syntax + +#### Usage + +#### Notes + +#### Etymology + + + + + + + + `\clearpage`{=latex} ## TIMER @@ -2630,7 +2682,7 @@ control is fully functional (end to end). The `XM` application provided in RomWBW is an adaptation of a pre-existing XModem application. Based on the source code comments, it was originally adapted from Ward Christensen's MODEM2 by Keith -Petersen and is labelled version 12.5. +Petersen and is labeled version 12.5. The original source of the application was found in the Walnut Creek CD-ROM and is called XMDM125.ARK dated 7/15/86. @@ -2643,3 +2695,57 @@ appropriate driver. The source code is provided in the RomWBW distribution. `\clearpage`{=latex} + +## ZMD + +| ZMD | | +| --------------------|---| +| ROM-based |No | +| Disk-based |Yes| + +#### Syntax + +#### Usage + +#### Notes + +#### Etymology + + + + + + + + +`\clearpage`{=latex} + +## ZMP + +| ZMP | | +| --------------------|---| +| ROM-based |No | +| Disk-based |Yes| + +#### Syntax + +#### Usage + +#### Notes + +#### Etymology + + + + + + + + + + + + + + +