Mercurial > hg > index.cgi
diff bas13.s @ 0:605ff82c4618
Initial check in with cleaned up sources
This is the initial check in the source code in a state where it builds byte
accurate copies of all the various ROM versions included.
| author | William Astle <lost@l-w.ca> |
|---|---|
| date | Sat, 08 Dec 2018 19:57:01 -0700 |
| parents | |
| children |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/bas13.s Sat Dec 08 19:57:01 2018 -0700 @@ -0,0 +1,4071 @@ + *pragma nolist + include defs.s + *pragma list +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; COLOR BASIC ROM +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + org BASIC +; This is the official set of ROM entry points. It is unfortunate that the generic input ("console in") routine is not exposed +; here. It is also unfortunate that no open and close file routines are exposed. This and other oversignts led to a lot of +; software either having to re-invent the wheel or calling directly into the ROM instead of via these official entry points. +POLCAT fdb KEYIN ; indirect jump, get a keystroke +CHROUT fdb PUTCHR ; indirect jump, output character +CSRDON fdb CASON ; indirect jump, turn cassette on and start reading +BLKIN fdb GETBLK ; indirect jump, read a block from tape +BLKOUT fdb SNDBLK ; indirect jump, write a block to tape +JOYIN fdb GETJOY ; indirect jump, read joystick axes +WRTLDR fdb WRLDR ; indirect jump, turn cassette on and write a leader +; Initialization code. +LA00E lds #LINBUF+LBUFMX+1 ; put the stack in the line input buffer which is a safe place for now + lda #0x37 ; enable the cartidge interrupt (to detect autostarting cartridges) + sta PIA1+3 + lda RSTFLG ; get warm start flag + cmpa #0x55 ; is it valid? + bne BACDST ; brif not - cold start + ldx RSTVEC ; get warm start routine pointer + lda ,x ; get first byte of the routine + cmpa #0x12 ; is it NOP? + bne BACDST ; brif not - the routine is invalid so do a cold start + jmp ,x ; transfer control to the warm start routine +; RESET/power on comes here +RESVEC leay LA00E,pcr ; point to warm start check code +LA02A ldx #PIA1 ; point to PIA1 - we're going to rely on the mirroring to reach PIA0 + clr -3,x ; set PIA0 DA to direction mode + clr -1,x ; set PIA0 DB to direction mode + clr -4,x ; set PIA0 DA to inputs + ldd #0xff34 + sta -2,x ; set PIA0 DB to outputs + stb -3,x ; set PIA0 DA to data mode + stb -1,x ; set PIA0 DB to data mode + clr 1,x ; set PIA1 DA to direction mode + clr 3,x ; set PIA1 DB to direction mode + deca + sta ,x ; set PIA1 DA bits 7-1 as output, 0 as input + lda #0xf8 ; set PIA1 DB bits 7-3 as output, 2-0 as input + sta 2,x + stb 1,x ; set PIA1 DA to data mode + stb 3,x ; set PIA1 DB to data mode + clr 2,x ; set VDG to alpha-numeric + ldb #2 ; make RS232 marking ("stop" bit) + stb ,x + ldu #SAMREG ; point to SAM register + ldb #16 ; 16 bits to clear +LA056 sta ,u++ ; clear a bit + decb ; done all? + bne LA056 ; brif not + sta SAMREG+9 ; put display at 0x400 + tfr b,dp ; set direct page to 0 + ldb #4 ; use as mask to check ram size input + clr -2,x ; strobe ram size low + bitb 2,x ; is the input set? + beq LA06E ; brif not + sta -5,u ; program SAM for 16Kx4 RAMs + sta -11,u ; the P bit is required to work with 16Kx4 RAMs + bra LA072 +LA06E nop + nop + sta -3,u ; program SAM for 64Kx1 RAMs +LA072 jmp ,y ; transfer control to startup routine +; Cold start jumps here +BACDST ldx #VIDRAM+1 ; point past the top of the first 1K of memory (for double predec below) +LA077 clr ,--x ; clear a byte (last will actually try clearing LSB of RESET vector in ROM) + leax 1,x ; move forward one byte (will set Z if we're done) + bne LA077 ; brif not donw yet + jsr LA928 ; clear the screen + clr ,x+ ; put the constant zero that lives before the program + stx TXTTAB ; set beginning of program storage +LA084 lda 2,x ; get value from memory + coma ; make it different + sta 2,x ; try putting different into memory + cmpa 2,x ; did it matcH? + bne LA093 ; brif not - we found the end of memory + leax 1,x ; move pointer forward + com 1,x ; restore the original memory contents + bra LA084 ; try another byte +LA093 stx TOPRAM ; save top of memory (one below actual top because we need a byte for VAL() to work) + stx MEMSIZ ; save top of string space + stx STRTAB ; set bottom of allocated string space + leax -200,x ; allocate 200 bytes of string space + stx FRETOP ; set top of actually free memory + tfr x,s ; put the stack there + ldx #LA10D ; point to variable initializer + ldu #CMPMID ; point to variables to initialize (first batch) + ldb #28 ; 28 bytes in first batch + jsr LA59A ; copy bytes to variables + ldu #IRQVEC ; point to variables to initialize (second batch) + ldb #30 ; 30 bytes this time + jsr LA59A ; copy bytes to variables + ldx -12,x ; get SN error address + stx 3,u ; set ECB's command handlers to error + stx 8,u + ldx #RVEC0 ; point to RAM vectors + ldd #0x394b ; write 75 RTS opcodes (25 RAM vectors) +LA0C0 sta ,x+ ; put an RTS + decb ; done? + bne LA0C0 ; brif not + sta LINHDR-1 ; make temporary line header data for line encoding have a nonzero next line pointer + jsr LAD19 ; do a "NEW" + ldx #'E*256+'X ; magic number to detect ECB ROM + cmpx EXBAS ; is there an ECB ROM? + lbeq EXBAS+2 ; brif so - launch it + andcc #0xaf ; start interrupts + ldx #LA147-1 ; point to sign on message + jsr LB99C ; print it out + ldx #BAWMST ; warm start routine address + stx RSTVEC ; set vector there + lda #0x55 ; warm start valid flag + sta RSTFLG ; mark warm start valid + bra LA0F3 ; go to direct mode +; Warm start entry point +BAWMST nop ; valid routine marker + clr DEVNUM ; reset output/input to screen + jsr LAD33 ; do a partial NEW + andcc #0xaf ; start interrupts + jsr LA928 ; clear the screen +LA0F3 jmp LAC73 ; go to direct mode +; FIRQ service routine - this handles starting autostart cartridges +BFRQSV tst PIA1+3 ; is it the cartridge interrupt? + bmi LA0FC ; brif so + rti +LA0FC jsr LA7D1 ; delay for a while + jsr LA7D1 ; delay for another while + leay <LA108,pcr ; point to cartridge starter + jmp LA02A ; go initialize everything clean for the cartridge +LA108 clr RSTFLG ; force a cold start a cartridge reset + jmp ROMPAK ; transfer control to the cartridge +; Variable initializers (first batch) +LA10D fcb 18 ; mid band partition of the 1200/2400 Hz period + fcb 24 ; upper limit of 1200 Hz period + fcb 10 ; upper limit of 2400 Hz period + fdb 128 ; number of 0x55s for cassette leader + fcb 11 ; cursor blink delay + fdb 88 ; 600 baud delay constant + fdb 1 ; printer carriage return delay constant + fcb 16 ; printer tab field width + fcb 112 ; last printer tab zone + fcb 132 ; printer carriage width + fcb 0 ; printer carriage position + fdb LB44A ; default execution address for EXEC + inc CHARAD+1 ;* character fetching routines (DP portion) - we first do a two + bne LA123 ;* two stage increment of CHARAD then load the value into A + inc CHARAD ;* before transferring control to the bottom half routine in ROM +LA123 lda >0 ; NOTE: the 0 is a placeholder, extended addressing is required + jmp BROMHK +; Variable initializers (second batch) + jmp BIRQSV ; IRQ handler + jmp BFRQSV ; FIRQ handler + jmp LB44A ; default USR() address + fcb 0x80,0x4f,0xc7,0x52,0x59 ; random seed + fcb 0xff ; capslock flag - default to upper case + fdb DEBDEL ; keyboard debounce delay (why is it a variable?) + jmp LB277 ; exponentiation handler vector + fcb 53 ; (command interpretation table) 53 commands + fdb LAA66 ; (command interpretation table) reserved words list (commands) + fdb LAB67 ; (command interpretation table) jump table (commands) + fcb 20 ; (command interpretation table) 20 functions + fdb LAB1A ; (command interpretation table) reserved words list (functions) + fdb LAA29 ; (command interpretation table) jump table (functions) +; This is the signon message. +LA147 fcc 'COLOR BASIC 1.3' + fcb 0x0d + fcc '(C) 1982 TANDY' + fcb 0 +; This is the "invalid colour" CLS easter egg text. Basically 11 wasted bytes +LA166 fcc 'MICROSOFT' + fcb 0x0d,0 +; Read a character from current device and mask off bit 7 (keep it as 7 bit ASCII) +LA171 bsr LA176 ; get character + anda #0x7f ; mask off high bit + rts +; Generic read routine. Reads a character from the device specified by DEVNUM. If no input was available, +; CINBFL will bet nonzero (on EOF). If input was available, CINBFL will be zero. Note that this routine +; has undefined results when called on an output only device. All registers except CC and A are preserved. +LA176 jsr RVEC4 ; do RAM hook + clr CINBFL ; flag data available + tst DEVNUM ; is it keyboard? + beq LA1B1 ; brif so - blink cursor and wait for key press + tst CINCTR ; is there anything in cassette input buffer? + bne LA186 ; brif so + com CINBFL ; flag EOF + rts +; Read character from cassette file +LA186 pshs u,y,x,b ; preserve registers + ldx CINPTR ; get input buffer pointer + lda ,x+ ; get character from buffer + pshs a ; save it for return + stx CINPTR ; save new input buffer pointer + dec CINCTR ; count character just consumed + bne LA197 ; brif buffer is not empty yet + jsr LA635 ; go read another block, if any, to refill the buffer +LA197 puls a,b,x,y,u,pc ; restore registers and return the character +; Blink the cursor. This might be better timed via an interrupt or something. +LA199 dec BLKCNT ; is it time to blink the cursor? + bne LA1AB ; brif not + ldb #11 ; reset blink timer + stb BLKCNT + ldx CURPOS ; get cursor position + lda ,x ; get character at the cursor + adda #0x10 ; move to next color + ora #0x8f ; make sure it's a grahpics block with all elements lit + sta ,x ; put new cursor block on screen +LA1AB ldx #DEBDEL ; we'll use the debounce delay for the cursor blink timer (10ms) +LA1AE jmp LA7D3 ; go count X down +; Blink cursor while waiting for a key press +LA1B1 pshs x,b ; save registers +LA1B3 bsr LA199 ; go do a cursor iteration + bsr KEYIN ; go read a key + beq LA1B3 ; brif no key pressed + ldb #0x60 ; VDG screen space character + stb [CURPOS] ; blank cursor out + puls b,x,pc ; restore registers and return +; This is the actual keyboard polling routine. Returns 0 if no new key is down. Compared to the 1.0 and 1.1 +; ROMs, this routine is quite a lot more compact and robust. +LA1C1 clr PIA0+2 ; strobe all columns + lda PIA0 ; get rows + coma ; bits set if keys down + lsla ; remove the comparator input + beq LA244 ; brif no keys down - don't actually poll the keyboard +KEYIN pshs u,x,b ; save registers + ldu #PIA0 ; point to keyboard PIA + ldx #KEYBUF ; point to state table + clra ; clear carry, set column to 0xff (no strobe) + deca ; (note: deca does not affect C) + pshs x,a ; save column counter and make a couple of holes for temporaries + sta 2,u ; set strobe to no columns +LA1D9 rol 2,u ; move to next column (C is 0 initially, 1 after) + bcc LA220 ; brif we shifted out a 0 - we've done 8 columns + inc 0,s ; bump column counter (first bump goes to 0) + bsr LA23A ; read row data + sta 1,s ; save key data (for debounce check and later saving) + eora ,x ; now bits set if key state changed + anda ,x ; now bits are only set if a key has been pressed + ldb 1,s ; get new key data + stb ,x+ ; save in state table + tsta ; was a key down? + beq LA1D9 ; brif not - do another (nothing above cleared C) + ldb 2,u ; get strobe data + stb 2,s ; save it for debounce check + ldb #0xf8 ; set up so B is 0 after first add +LA1F4 addb #8 ; add 8 for each row + lsra ; did we hit the right row? + bcc LA1F4 ; brif not + addb 0,s ; add in column number + beq LA245 ; brif @ + cmpb #26 ; letter? + bhi LA247 ; brif not + orb #0x40 ; bias into letter range + bsr LA22E ; check for SHIFT + ora CASFLG ; merge in capslock state + bne LA20C ; brif either capslock or SHIFT - keep upper case + orb #0x20 ; move to lower case +LA20C stb 0,s ; save ASCII value + ldx DEBVAL ; get debounce delay + bsr LA1AE ; do the 10ms debounce delay + ldb #0xff ; set strobe to none - only joystick buttons register now + bsr LA238 ; read keyboard + inca ; A now 0 if no buttons down + bne LA220 ; brif button down - return nothing since we have interference +LA21A ldb 2,s ; get column strobe data + bsr LA238 ; read row data + cmpa 1,s ; does it match original read? +LA220 puls a,x ; clean up stack and get return value + bne LA22B ; brif failed debounce or a joystick button down + cmpa #0x12 ; is it SHIFT-0? + bne LA22C ; brif not + com CASFLG ; swap capslock state +LA22B clra ; set no key down +LA22C puls b,x,u,pc ; restore registers and return +LA22E lda #0x7f ; column strobe for SHIFT + sta 2,u ; set column + lda ,u ; get row data + coma ; set if key down + anda #0x40 ; only keep SHIFT state + rts +LA238 stb 2,u ; save strobe data +LA23A lda ,u ; get row data + ora #0x80 ; mask off comparator so it doesn't interfere + tst 2,u ; are we on column 7? + bmi LA244 ; brif not + ora #0xc0 ; also mask off SHIFT +LA244 rts +LA245 ldb #51 ; scan code for @ +LA247 ldx #CONTAB-0x36 ; point to code table + cmpb #33 ; arrows, space, zero? + blo LA264 ; brif so + ldx #CONTAB-0x54 ; adjust to other half of table + cmpb #48 ; ENTER, CLEAR, BREAK, @? + bhs LA264 ; brif so + bsr LA22E ; read shift state + cmpb #43 ; is it a number, colon, semicolon? + bls LA25D ; brif so + eora #0x40 ; invert shift state for others +LA25D tsta ; shift down? + bne LA20C ; brif not - return result + addb #0x10 ; add in offset to shifted character + bra LA20C ; go return result +LA264 lslb ; two entries per key + bsr LA22E ; check SHIFT state + beq LA26A ; brif not shift + incb ; point to shifted entry +LA26A ldb b,x ; get actual key code + bra LA20C ; go return result +CONTAB fcb 0x5e,0x5f ; <UP> (^, _) + fcb 0x0a,0x5b ; <DOWN> (LF, [) + fcb 0x08,0x15 ; <LEFT> (BS, ^U) + fcb 0x09,0x5d ; <RIGHT> (TAB, ]) + fcb 0x20,0x20 ; <SPACE> + fcb 0x30,0x12 ; <0> (0, ^R) + fcb 0x0d,0x0d ; <ENTER> (CR, CR) + fcb 0x0c,0x5c ; <CLEAR> (FF, \) + fcb 0x03,0x03 ; <BREAK> (^C, ^C) + fcb 0x40,0x13 ; <@> (@, ^S) +; Generic output routine. +; Output character in A to the device specified by DEVNUM. All registers are preserved except CC. +; Sending output to a device that does not support output is undefined. +PUTCHR jsr RVEC3 ; call RAM hook + pshs b ; save B + ldb DEVNUM ; get desired device number + incb ; set flags (Z for -1, etc.) + puls b ; restore B + bmi LA2BF ; brif < -1 (line printer) + bne LA30A ; brif > -1 (screen) +; Write character to tape file + pshs x,b,a ; save registers + ldb FILSTA ; get file status + decb ; input file? + beq LA2A6 ; brif so + ldb CINCTR ; get character count + incb ; account for this character + bne LA29E ; brif buffer not full + bsr LA2A8 ; write previously full block to tape +LA29E ldx CINPTR ; get output buffer pointer + sta ,x+ ; put character in output + stx CINPTR ; save new buffer pointer + inc CINCTR ; account for this character +LA2A6 puls a,b,x,pc ; restore registers and return +; Write a block of data to tape. +LA2A8 ldb #1 ; data block type +LA2AA stb BLKTYP ; set block type + ldx #CASBUF ; point to output buffer + stx CBUFAD ; set buffer pointer + ldb CINCTR ; get number of bytes in the block + stb BLKLEN ; set length to write + pshs u,y,a ; save registers + jsr LA7E5 ; write a block to tape + puls a,y,u ; restore registers + jmp LA650 ; reset buffer pointers +; Send byte to line printer +LA2BF pshs x,b,a,cc ; save registers and interrupt status + orcc #0x50 ; disable interrupts +LA2C3 ldb PIA1+2 ; get RS232 status + lsrb ; get status to C + bcs LA2C3 ; brif busy - loop until not busy + bsr LA2FB ; set output to marking + clrb ; transmit one start bit + bsr LA2FD + ldb #8 ; counter for 8 bits +LA2D0 pshs b ; save bit count + clrb ; zero output bits + lsra ; bet output bit to C + rolb ; get output bit to correct bit for output byte + lslb + bsr LA2FD ; transmit bit + puls b ; get back bit counter + decb ; are we done yet? + bne LA2D0 ; brif not + bsr LA2FB ; send stop bit (marking) + puls cc,a ; restore interrupt status and output character + cmpa #0x0d ; carriage return? + beq LA2ED ; brif so + inc LPTPOS ; bump output position + ldb LPTPOS ; get new position + cmpb LPTWID ; end of line? + blo LA2F3 ; brif not +LA2ED clr LPTPOS ; reset position to start of line + bsr LA305 ; do carriage return delay + bsr LA305 +LA2F3 ldb PIA1+2 ; get RS232 status + lsrb ; get status to C + bcs LA2F3 ; brif still busy, keep waiting + puls b,x,pc ; restore registers and return +LA2FB ldb #2 ; set output to high (marking) +LA2FD stb PIA1 ; set RS232 output + bsr LA302 ; do baud delay (first iteration) then fall through for second +LA302 ldx LPTBTD ; get buard rate delay constant + skip2 +LA305 ldx LPTLND ; get carriage return delay constant + jmp LA7D3 ; count X down +; Output character to screen +LA30A pshs x,b,a ; save registers + ldx CURPOS ; get cursor pointer + cmpa #0x08 ; backspace? + bne LA31D ; brif not + cmpx #VIDRAM ; at top of screen? + beq LA35D ; brif so - it's a no-op + lda #0x60 ; VDG space character + sta ,-x ; put a space at previous location and move pointer back + bra LA344 ; save new cursor position and return +LA31D cmpa #0x0d ; carriage return? + bne LA32F ; brif not + ldx CURPOS ; get cursor pointer (why? we already have it) +LA323 lda #0x60 ; VDG space character + sta ,x+ ; put output space + tfr x,d ; see if we at a multiple of 32 now + bitb #0x1f + bne LA323 ; brif not + bra LA344 ; go check for scrolling +LA32F cmpa #0x20 ; control character? + blo LA35D ; brif so + tsta ; is it graphics block? + bmi LA342 ; brif so + cmpa #0x40 ; number or special? + blo LA340 ; brif so (flip "case" bit) + cmpa #0x60 ; upper case alpha? + blo LA342 ; brif so - keep it unmodified + anda #0xdf ; clear bit 5 (inverse video) +LA340 eora #0x40 ; flip inverse video bit +LA342 sta ,x+ ; output character +LA344 stx CURPOS ; save new cursor position + cmpx #VIDRAM+511 ; end of screen? + bls LA35D ; brif not + ldx #VIDRAM ; point to start of screen +LA34E ldd 32,x ; get two characters from next row + std ,x++ ; put them on this row + cmpx #VIDRAM+0x1e0 ; at start of last row on screen? + blo LA34E ; brif not + ldb #0x60 ; VDG space + jsr LA92D ; blank out last line (borrow CLS's loop) +LA35D puls a,b,x,pc ; restore registers and return +; Set up device parameters for output +LA35F jsr RVEC2 ; do the RAM hook dance + pshs x,b,a ; save registers + clr PRTDEV ; flag device as a screen + lda DEVNUM ; get devicenumber + beq LA373 ; brif screen + inca ; is it tape? + beq LA384 ; brif so + ldx LPTCFW ; get tab width and last tab stop for printer + ldd LPTWID ; get line width and current position for printer + bra LA37C ; set parameters +LA373 ldb CURPOS+1 ; get LSB of cursor position + andb #0x1f ; now we have the offset into the line + ldx #0x1010 ; 16 character tab, position 16 is last tab stop + lda #32 ; screen is 32 characters wide +LA37C stx DEVCFW ; save tab width and last tab stop for active device + stb DEVPOS ; save line position for current device + sta DEVWID ; save line width for current device + puls a,b,x,pc ; restore registers and return +LA384 com PRTDEV ; flag device as non-display + ldx #0x0100 ; tab width is 1, last tab field is 0 + clra ; line width is 0 + clrb ; character position on line is 0 + bra LA37C ; go set parameters +; This is the line input routine used for reading lines for Basic, both in immediate mode and for +; INPUT and LINE INPUT. Exit with C set if terminated by BREAK and C clear if terminated by ENTER. +; The actualy entry point is LA390. Note that this routine echoes to *all* devices. +LA38D jsr LA928 ; clear screen (CLEAR key handling) +LA390 jsr RVEC12 ; do the RAM hook dance + clr IKEYIM ; reset cached input character from BREAK check + ldx #LINBUF+1 ; point to line input buffer (input pointer) + ldb #1 ; Number of characters in line (we start at 1 so BS handling is easier) +LA39A jsr LA171 ; get an input character, only keep low 7 bits + tst CINBFL ; is it EOF? + bne LA3CC ; brif EOF + tst DEVNUM ; is it keyboard input? + bne LA3C8 ; brif not - don't do line editing + cmpa #0x0c ; form feed (CLEAR)? + beq LA38D ; brif so - clear screen and reset + cmpa #0x08 ; backspace? + bne LA3B4 ; brif not + decb ; move back one character + beq LA390 ; brif we were at the start of the line - reset and start again + leax -1,x ; move input pointer back + bra LA3E8 ; echo the backspace and continue +LA3B4 cmpa #0x15 ; SHIFT-LEFT (kill line)? + bne LA3C2 ; brif not +LA3B8 decb ; at start of line? + beq LA390 ; brif so - reset and restart + lda #0x08 ; echo a backspace + jsr PUTCHR + bra LA3B8 ; see if we've erased everything yet +LA3C2 cmpa #0x03 ; BREAK? + orcc #1 ; set C if it is (only need Z for the next test + beq LA3CD ; brif BREAK - exit +LA3C8 cmpa #0x0d ; ENTER (CR) + bne LA3D9 ; brif not +LA3CC clra ; clear carry (it might not be clear on EOF) +LA3CD pshs cc ; save ENTER/BREAK flag + jsr LB958 ; echo a carriage return + clr ,x ; make sure we have a NUL at the end of the buffer + ldx #LINBUF ; point to input buffer + puls cc,pc ; restore ENTER/BREAK flag and return +LA3D9 cmpa #0x20 ; control character? + blo LA39A ; brif so - skip it + cmpa #'z+1 ; above z? + bhs LA39A ; brif so - ignore it + cmpb #LBUFMX ; is the buffer full? + bhs LA39A ; brif so - ignore extra characters + sta ,x+ ; put character in the buffer + incb ; bump character count +LA3E8 jsr PUTCHR ; echo character + bra LA39A ; go handle next input character +; Check if DEVNUM Is valid for reading. Raise FM error if open but not for reading. NO error if not open. +LA3ED jsr RVEC5 ; do the RAM hook dance + lda DEVNUM ; get device number + beq LA415 ; brif keyboard - always valid + inca ; is it tape? + bne LA403 ; brif not + lda FILSTA ; get tape file status + bne LA400 ; brif file is open +LA3FB ldb #22*2 ; raise NO error + jmp LAC46 +LA400 deca ; is it in input mode? + beq LA415 ; brif so +LA403 jmp LA616 ; raise FM error +; Check if DEVNUM is valid for writing. Raise FM error if open but not for writing. NO error if not open. +LA406 jsr RVEC6 ; do the RAM hook dance + lda DEVNUM ; get device number + inca ; is it tape? + bne LA415 ; brif not + lda FILSTA ; get file status + beq LA3FB ; brif not open + deca ; is it open for reading? + beq LA403 ; brif so - bad mode +LA415 rts +; CLOSE command +CLOSE beq LA426 ; brif no file specified - close all files + jsr LA5A5 ; parse device number +LA41B bsr LA42D ; close specified file + jsr GETCCH ; is there more? + beq LA44B ; brif not + jsr LA5A2 ; check for comma and parse another device number + bra LA41B ; go close this one +; Close all files handler. +LA426 jsr RVEC7 ; Yup. The RAM hook dance. + lda #-1 ; start with tape file + sta DEVNUM +; Close file specified in DEVNUM. Note that this never fails. +LA42D jsr RVEC8 ; You know it. RAM hook. + lda DEVNUM ; get device we're closing + clr DEVNUM ; reset to screen/keyboard + inca ; is it tape? + bne LA44B ; brif not + lda FILSTA ; get file status + cmpa #2 ; is it output? + bne LA449 ; brif not + lda CINCTR ; is there anything waiting to be written? + beq LA444 ; brif not + jsr LA2A8 ; write final block of data +LA444 ldb #0xff ; write EOF block + jsr LA2AA +LA449 clr FILSTA ; mark tape file closed +LA44B rts +; CSAVE command +CSAVE jsr LA578 ; parse filename + jsr GETCCH ; see what we have after the file name + beq LA469 ; brif none + jsr LB26D ; make sure there's a comma + ldb #'A ; make sure there's an A after + jsr LB26F + bne LA44B ; brif not end of line + clra ; file type 0 (basic program) + jsr LA65C ; write out header block + lda #-1 ; set output to tape + sta DEVNUM + clra ; set Z so we list the whole program + jmp LIST ; go list the program to tape +LA469 clra ; file type 0 (basic program) + ldx ZERO ; set to binary file mode + jsr LA65F ; write header block + clr FILSTA ; close files + inc BLKTYP ; set block type to data + jsr WRLDR ; write out a leader + ldx TXTTAB ; point to start of program +LA478 stx CBUFAD ; set buffer location + lda #255 ; block size to 255 bytes (max size) + sta BLKLEN + ldd VARTAB ; get end of program + subd CBUFAD ; how much is left? + beq LA491 ; brif we have nothing left + cmpd #255 ; do we have a full block worth? + bhs LA48C ; brif so + stb BLKLEN ; save actual remainder as block length +LA48C jsr SNDBLK ; write a block out + bra LA478 ; go do another block +LA491 neg BLKTYP ; set block type to 0xff (EOF) + clr BLKLEN ; no data in EOF block + jmp LA7E7 ; write EOF, stop tape, and return +; CLOAD and CLOADM commands +CLOAD clr FILSTA ; close tape file + cmpa #'M ; is it ClOADM? + beq LA4FE ; brif so + leas 2,s ; clean up stack + jsr LA5C5 ; parse file name + jsr LA648 ; go find the file + tst CASBUF+10 ; is it binary? + beq LA4C8 ; brif so + lda CASBUF+9 ; is it ASCII? + beq LA4CD ; brif not + jsr LAD19 ; clear out existing program + lda #-1 ; set up for reading from tape + sta DEVNUM + inc FILSTA ; set tape file to input + jsr LA635 ; go read first block + jmp LAC7C ; go to immediate mode to read in the program +; This is the EOF handler for immediate mode. It's rather assinine for this to be located here. It is +; probably an artifact of a substantially different code layout prior to compacting the ROM to fit in +; 8K. +LA4BF jsr RVEC13 ; do the RAM hook dance + jsr LA42D ; close file + jmp LAC73 ; go back to immediate mode +LA4C8 lda CASBUF+8 ; get file type + beq LA4D0 ; brif basic program +LA4CD jmp LA616 ; raise FM error +LA4D0 jsr LAD19 ; erase existing program + jsr CASON ; start reading tape + ldx TXTTAB ; get start of program storage +LA4D8 stx CBUFAD ; set load address for block + ldd CBUFAD ; get start of block + inca ; bump by 256 + jsr LAC37 ; check if there's room for a maximum sized block of 255 + jsr GETBLK ; go read a block + bne LA4F8 ; brif there was an error during reading + lda BLKTYP ; get type of block read + beq LA4F8 ; brif header block - IO error + bpl LA4D8 ; brif data block - read another + stx VARTAB ; save new end of program + bsr LA53B ; stop tape + ldx #LABED-1 ; point to "OK" prompt + jsr LB99C ; show prompt + jmp LACE9 ; reset various things and return +LA4F8 jsr LAD19 ; clear out partial program load +LA4FB jmp LA619 ; raise IO error +; This is the CLOADM command +LA4FE jsr GETNCH ; eat the "M" + bsr LA578 ; parse file name + jsr LA648 ; go find the file +LA505 ldx ZERO ; default offset is 0 + jsr GETCCH ; see if there's something after the file name + beq LA511 ; brif no offset + jsr LB26D ; make sure there's a comma + jsr LB73D ; evaluate offset to X +LA511 lda CASBUF+8 ; get file mode + cmpa #2 ; M/L program? + bne LA4CD ; brif not - FM error + ldd CASBUF+11 ; get load address + leau D,x ; add in offset + stu EXECJP ; set EXEC default address + tst CASBUF+10 ; is it binary? + bne LA4CD ; brif not + ldd CASBUF+13 ; get load address + leax d,x ; add in offset + stx CBUFAD ; set buffer address for loading + jsr CASON ; start up tape +LA52E jsr GETBLK ; read a block + bne LA4FB ; brif error reading + stx CBUFAD ; save new load address + tst BLKTYP ; set flags on block type + beq LA4FB ; brif another header - IO error + bpl LA52E ; brif it was data - read more +LA53B jmp LA7E9 ; turn off tape and return +; The EXEC command +EXEC beq LA545 ; brif no argument - use default address + jsr LB73D ; evaluate EXEC address to X + stx EXECJP ; set new default EXEC address +LA545 jmp [EXECJP] ; transfer control to execution address +; Break check for LIST so it doesn't interrupt ASCII saves. Why is this here instead of with the rest of the break +; check logic or packaged up with LIST? +LA549 jsr RVEC11 ; do the RAM hook dance + lda DEVNUM ; get device number + inca ; is it tape? + beq LA5A1 ; brif so - don't do break check + jmp LADEB ; do the actual break check +; Evaluate an expression and make sure it is within the limits of the screen and sets the cursor position. +; This really should be located with the PRINT command. +LA554 jsr LB3E4 ; evaluate a positive expression to D + subd #511 ; is it within bounds? + lbhi LB44A ; brif not - error out + addd #VIDRAM+511 ; adjust to be within the screen (and undo the SUBD above) + std CURPOS ; set cursor position + rts +; INKEY$ function +INKEY lda IKEYIM ; was a key down during break check? + bne LA56B ; brif so + jsr KEYIN ; poll the keyboard +LA56B clr IKEYIM ; reset the break check cache + sta FPA0+3 ; store result for later return + lbne LB68F ; brif a key was down - return it as a string + sta STRDES ; set string length to 0 (no key down) + jmp LB69B ; return the NULL string +; Parse a filename +LA578 ldx #CFNBUF ; point to file name buffer + clr ,x+ ; zero out file name length + lda #0x20 ; space character to initialize file name +LA57F sta ,x+ ; put a space in the buffer + cmpx #CASBUF ; at end of file name? + bne LA57F ; brif not + jsr GETCCH ; get input character + beq LA5A1 ; brif no name present + jsr LB156 ; evaluate the file name expression + jsr LB654 ; point to start of the file name + ldu #CFNBUF ; point to file name buffer + stb ,u+ ; save string length + beq LA5A1 ; brif empty - we're done + skip2 +LA598 ldb #8 ; copy 8 bytes +; Move B bytes from (X) to (U) +LA59A lda ,x+ ; copy a byte + sta ,u+ + decb ; done yet? + bne LA59A ; brif not +LA5A1 rts +; Parse a device number and check validity +LA5A2 jsr LB26D ; check for comma and SN error if not +LA5A5 cmpa #'# ; do we have a #? + bne LA5AB ; brif not (it's optional) + jsr GETNCH ; munch the # +LA5AB jsr LB141 ; evaluate the expression +LA5AE jsr INTCNV ; convert it to an integer in D + rolb ; move sign of B into C + adca #0 ; add sign of B to A + bne LA61F ; brif A doesn't match the sign of B + rorb ; restore B (ADCA will have set C if B was negative) + stb DEVNUM ; set device number + jsr RVEC1 ; do the RAM hook dance + beq LA5C4 ; brif device number set to screen/keyboard (valid) + bpl LA61F ; brif not negative (not valid) + cmpb #-2 ; is it printer or tape? + blt LA61F ; brif not (not valid) +LA5C4 rts +; Read file name from the line and do an error if anything follows it +LA5C5 bsr LA578 ; parse file name + jsr GETCCH ; set flags on current character +LA5C9 beq LA5C4 ; brif nothing there - it's good + jmp LB277 ; raise SN error +; EOF functoin +EOF jsr RVEC14 ; do the RAM hook dance + lda DEVNUM ; get device number + pshs a ; save it (so we can restore it later) + bsr LA5AE ; check the device number (which is in FPA0) + jsr LA3ED ; check validity for reading +LA5DA clrb ; not EOF = 0 (FALSE) + lda DEVNUM ; get device number + beq LA5E4 ; brif keyboard - never EOF + tst CINCTR ; is there anything in the input buffer? + bne LA5E4 ; brif so - not EOF + comb ; set EOF flag to -1 (true) +LA5E4 puls a ; get back original device + sta DEVNUM ; restore it +LA5E8 sex ; sign extend result to 16 bits + jmp GIVABF ; go return the result +; SKIPF command +SKIPF bsr LA5C5 ; parse file name + bsr LA648 ; look for the file + jsr LA6D1 ; read the file + bne LA619 ; brif error reading file + rts +; OPEN command +OPEN jsr RVEC0 ; do the RAM hook dance + jsr LB156 ; get file status (input/output) + jsr LB6A4 ; get first character of status string + pshs b ; save status + bsr LA5A2 ; parse a comma then the device number + jsr LB26D ; make sure there's a comma + bsr LA5C5 ; parse the file name + lda DEVNUM ; get device number of the file + clr DEVNUM ; reset actual device to the screen + puls b ; get back status + cmpb #'I ; INPUT? + beq LA624 ; brif so - open a file for INPUT + cmpb #'O ; OUTPUT? + beq LA658 ; brif so - open a file for OUTPUT +LA616 ldb #21*2 ; raise FM error + skip2 +LA619 ldb #20*2 ; raise I/O error + skip2 +LA61C ldb #18*2 ; raise AO error + skip2 +LA61F ldb #19*2 ; raise DN error + jmp LAC46 +LA624 inca ; are we opening the tape? + bmi LA616 ; brif printer - FM error; printer can't be opened for READ + bne LA657 ; brif screen - screen is always open + bsr LA648 ; read header block + lda CASBUF+9 ; clear A if binary or machine language file + anda CASBUF+10 + beq LA616 ; bad file mode if not data file + inc FILSTA ; open file for input +LA635 jsr LA701 ; start tape, read block + bne LA619 ; brif error during read + tst BLKTYP ; check block type + beq LA619 ; brif header block - something's wrong + bmi LA657 ; brif EOF + lda BLKLEN ; get length of block + beq LA635 ; brif empty block - read another +LA644 sta CINCTR ; set buffer count + bra LA652 ; reset buffer pointer +LA648 tst FILSTA ; is the file open? + bne LA61C ; brif so - AO error + bsr LA681 ; search for file + bne LA619 ; brif error on read +LA650 clr CINCTR ; mark buffer empty +LA652 ldx #CASBUF ; set buffer pointer to start of buffer + stx CINPTR +LA657 rts +LA658 inca ; check for tape device + bne LA657 ; brif not tape (nothing doing - it's always open) + inca ; make file type 1 +LA65C ldx #0xffff ; ASCII and data mode +LA65F tst FILSTA ; is file open? + bne LA61C ; brif so - raise error + ldu #CASBUF ; point to tape buffer + stu CBUFAD ; set address of block to write + sta 8,u ; set file type + stx 9,u ; set ASCII flag and mode + ldx #CFNBUF+1 ; point to file name + jsr LA598 ; move file name to the tape buffer + clr BLKTYP ; set for header block + lda #15 ; 15 bytes in a header block + sta BLKLEN ; set block length + jsr LA7E5 ; write the block + lda #2 ; set file type to output + sta FILSTA + bra LA650 ; reset file pointers +; Search for correct cassette file name +LA681 ldx #CASBUF ; point to cassette buffer + stx CBUFAD ; set location to read blocks to +LA686 lda CURLIN ; are we in immediate mode? + inca + bne LA696 ; brif not + jsr LA928 ; clear screen + ldx CURPOS ; get start of screen (set after clear) + ldb #'S ; for "searching" + stb ,x++ ; put it on the screen + stx CURPOS ; save cursor position to be one past the search indicator +LA696 bsr LA701 ; read a block + orb BLKTYP ; merge error flag with block type + bne LA6D0 ; brif error or not header + ldx #CASBUF ; point to block just read + ldu #CFNBUF+1 ; point to the desired name + ldb #8 ; compare 8 characters + clr ,-s ; set flag to "match" +LA6A6 lda ,x+ ; get character from just read block + ldy CURLIN ; immediate mode? + leay 1,y + bne LA6B4 ; brif not + clr DEVNUM ; set output to screen + jsr PUTCHR ; display character +LA6B4 suba ,u+ ; subtract from desired file name (nonzero if no match) + ora ,s ; merge with match flag + sta ,s ; save new match flag (will be nonzero if any character differs) + decb ; done all characters? + bne LA6A6 ; brif not - do another + lda ,s+ ; get match flag (and set flags) + beq LA6CB ; brif we have a match + tst -9,u ; did we actually have a file name or will any file do? + beq LA6CB ; brif any file will do + bsr LA6D1 ; go read past the file + bne LA6D0 ; return on error + bra LA686 ; keep looking +LA6CB lda #'F ; for "found" + bsr LA6F8 ; put "F" on screen + clra ; set Z to indicat eno errors +LA6D0 rts +LA6D1 tst CASBUF+10 ; check type of file + bne LA6DF ; brif "blocked" file + jsr CASON ; turn on tape +LA6D9 bsr GETBLK ; read a block + bsr LA6E5 ; error or EOF? + bra LA6D9 ; read another block +LA6DF bsr LA701 ; read a single block + bsr LA6E5 ; error or EOF? + bra LA6DF ; read another block +LA6E5 bne LA6ED ; got error reading block + lda BLKTYP ; check block type + nega ; A is 0 now if EOF + bmi LA700 ; brif not end of file + deca ; clear error indicator +LA6ED sta CSRERR ; set error flag + leas 2,s ; don't return to original caller + bra LA705 ; turn off motor and return +LA6F3 lda VIDRAM ; get first char on screen + eora #0x40 ; flip case +LA6F8 ldb CURLIN ; immediate mode? + incb + bne LA700 ; brif not + sta VIDRAM ; save flipped case character +LA700 rts +; Read a single block from tape (for a "blocked" file) +LA701 bsr CASON ; start tape going + bsr GETBLK ; read block +LA705 jsr LA7E9 ; stop tape + ldb CSRERR ; get error status + rts +; Read a block from tape - this does the heavy lifting +GETBLK orcc #0x50 ; disable interrupts (timing is important) + bsr LA6F3 ; reverse video of upper left character in direct mode + ldx CBUFAD ; point to destination buffer + clra ; reset read byte +LA712 bsr LA755 ; read a bit + rora ; move bit into accumulator + cmpa #0x3c ; have we synched on the start of the block data yet? + bne LA712 ; brif not + bsr LA749 ; read block type + sta BLKTYP + bsr LA749 ; get block size + sta BLKLEN + adda BLKTYP ; accumulate checksum + sta CCKSUM ; save current checksum + lda BLKLEN ; get back count + sta CSRERR ; initialize counter; we use this since it will be ovewritten later anyway + beq LA73B ; brif empty block +LA72B bsr LA749 ; read a byte + sta ,x ; save in buffer + cmpa ,x+ ; make sure it wrote + bne LA744 ; brif error if it didn't match + adda CCKSUM ; accumulate checksum + sta CCKSUM + dec CSRERR ; read all bytes? + bne LA72B ; brif not +LA73B bsr LA749 ; read checksum from tape + suba CCKSUM ; does it match? + beq LA746 ; brif so + lda #1 ; checksum error flag + skip2 +LA744 lda #2 ; non-RAM error flag +LA746 sta CSRERR ; save error status + rts +LA749 lda #8 ; read 8 bits + sta CPULWD ; initialize counter +LA74D bsr LA755 ; read a bit + rora ; put it into accumulator + dec CPULWD ; got all 8 bits? + bne LA74D ; brif not + rts +LA755 bsr LA75D ; get time between transitions + ldb CPERTM ; get timer + decb + cmpb CMPMID ; set C if timer is below the transition point - high or 1; clear otherwise + rts +LA75D clr CPERTM ; reset timer + tst CBTPHA ; check which phase we synched on + bne LA773 ; brif HI-LO synch +LA763 bsr LA76C ; read input + bcs LA763 ; brif still high +LA767 bsr LA76C ; read input + bcc LA767 ; brif still low + rts +LA76C inc CPERTM ; bump timer + ldb PIA1 ; get input bit to C + rorb + rts +LA773 bsr LA76C ; read input + bcc LA773 ; brif still low +LA777 bsr LA76C ; read output + bcs LA777 ; brif still high + rts +; Start tape and look for sync bytes +CASON orcc #0x50 ; disable interrupts + bsr LA7CA ; turn on tape + clr CPULWD ; reset timer +LA782 bsr LA763 ; wait for low-high transition +LA784 bsr LA7AD ; wait for it to go low again + bhi LA797 ; brif in range for 1200 Hz +LA788 bsr LA7A7 ; wait for it to go high again + blo LA79B ; brif in range for 2400 Hz + dec CPULWD ; decrement counter (synched on low-high) + lda CPULWD ; get counter + cmpa #-96 ; have we seen 96 1-0-1-0 patterns (48 0x55s)? +LA792 bne LA782 ; brif not - wait some more + sta CBTPHA ; save phase we synched on + rts +LA797 bsr LA7A7 ; wait for it to go high again + bhi LA784 ; brif another 1200 Hz, 2 in a row, try again +LA79B bsr LA7AD ; wait for it to go low again + blo LA788 ; brif another 2400 Hz; go try again for high + inc CPULWD ; bump counter + lda CPULWD ; get counter + suba #96 ; set 0 if we've seen enought 0-1-0-1 patterns (0xaa) + bra LA792 ; set phase and return or keep waiting +LA7A7 clr CPERTM ; reset period timer + bsr LA767 ; wait for high + bra LA7B1 ; set flags on result +LA7AD clr CPERTM ; reset period timer + bsr LA777 ; wait for low +LA7B1 ldb CPERTM ; get period count + cmpb CMP0 ; is it too long for 1200Hz? + bhi LA7BA ; brif so - reset counts + cmpb CMP1 ; set C if 2400Hz, clear C if 1200 Hz + rts +LA7BA clr CPULWD ; reset sync counter (too slow or drop out) + rts +; MOTOR command +MOTOR tfr a,b ; save ON/OFF + jsr GETNCH ; eat the ON/OFF token + cmpb #0xaa ; OFF? + beq LA7E9 ; brif so - turn off tape + cmpb #0x88 ; ON? + jsr LA5C9 ; SN error if no match +; Turn on tape +LA7CA lda PIA1+1 ; get motor control value + ora #8 ; turn on bit 3 (starts motor) + bsr LA7F0 ; put it back (dumb but it saves a byte) +LA7D1 ldx ZERO ; maximum delay timer +LA7D3 leax -1,x ; count down + bne LA7D3 ; brif not at 0 yet + rts +; Write a synch leader to tape +WRLDR orcc #0x50 ; disable interrupts + bsr LA7CA ; turn on tape + ldx SYNCLN ; get count of 0x55s to write +LA7DE bsr LA828 ; write a 0x55 + leax -1,x ; done? + bne LA7DE ; brif not + rts +; Write sync bytes and a block, then stop tape +LA7E5 bsr WRLDR ; write sync +LA7E7 bsr SNDBLK ; write block +; Turn off tape +LA7E9 andcc #0xaf ; enable interrupts + lda PIA1+1 ; get control register + anda #0xf7 ; disable motor bit +LA7F0 sta PIA1+1 ; set motor enable bit + rts +; Write a block to tape. +SNDBLK orcc #0x50 ; disable interrupts + ldb BLKLEN ; get block size + stb CSRERR ; initialize character counter + lda BLKLEN ; initialize checksum + beq LA805 ; brif empty block + ldx CBUFAD ; point to tape buffer +LA800 adda ,x+ ; accumulate checksum + decb ; end of block data? + bne LA800 ; brif not +LA805 adda BLKTYP ; accumulate block type into checksum + sta CCKSUM ; save calculated checksum + ldx CBUFAD ; point to buffer + bsr LA828 ; send a 0x55 + lda #0x3c ; and then a 0x3c + bsr LA82A + lda BLKTYP ; send block type + bsr LA82A + lda BLKLEN ; send block size + bsr LA82A + tsta ; empty block? + beq LA824 ; brif so +LA81C lda ,x+ ; send character from block data + bsr LA82A + dec CSRERR ; are we done yet? + bne LA81C ; brif not +LA824 lda CCKSUM ; send checksum + bsr LA82A +LA828 lda #0x55 ; send a 0x55 +LA82A pshs a ; save output byte + ldb #1 ; initialize bit probe +LA82E lda CLSTSN ; get ending value of last cycle + sta PIA1 ; set DA + ldy #LA85C ; point to sine wave table + bitb ,s ; is bit set? + bne LA848 ; brif so - do high frequency +LA83B lda ,y+ ; get next sample (use all for low frequency) + cmpy #LA85C+36 ; end of table? + beq LA855 ; brif so + sta PIA1 ; set output sample + bra LA83B ; do another sample +LA848 lda ,y++ ; get next sample (use every other for high frequency) + cmpy #LA85C+36 ; end of table? + beq LA855 ; brif so + sta PIA1 ; send output sample + bra LA848 ; do another sample +LA855 sta CLSTSN ; save last sample that *would* have been sent + lslb ; shift mask to next bit + bcc LA82E ; brif not done all 8 bits + puls a,pc ; get back original character and return +; This is the sample table for the tape sine wave +LA85C fcb 0x82,0x92,0xaa,0xba,0xca,0xda + fcb 0xea,0xf2,0xfa,0xfa,0xfa,0xf2 + fcb 0xea,0xda,0xca,0xba,0xaa,0x92 + fcb 0x7a,0x6a,0x52,0x42,0x32,0x22 + fcb 0x12,0x0a,0x02,0x02,0x02,0x0a + fcb 0x12,0x22,0x32,0x42,0x52,0x6a +; SET command +SET bsr LA8C1 ; get absolute screen position of graphics block + pshs x ; save character location + jsr LB738 ; evaluate comma then expression in B + puls x ; get back character pointer + cmpb #8 ; valid colour? + bhi LA8D5 ; brif not + decb ; normalize colours + bmi LA895 ; brif colour 0 (use current colour) + lda #0x10 ; 16 patterns per colour + mul + bra LA89D ; go save the colour +LA895 ldb ,x ; get current value + bpl LA89C ; brif not grahpic + andb #0x70 ; keep only the colour + skip1 +LA89C clrb ; reset block to all black +LA89D pshs b ; save colour + bsr LA90D ; force a ) + lda ,x ; get current screen value + bmi LA8A6 ; brif graphic block already + clra ; force all pixels off +LA8A6 anda #0x0f ; keep only pixel data + ora GRBLOK ; set the desired pixel + ora ,s+ ; merge with desired colour +LA8AC ora #0x80 ; force it to be a graphic block + sta ,x ; put new block on screen + rts +; RESET command +RESET bsr LA8C1 ; get address of desired block + bsr LA90D ; force a ) + clra ; zero block (no pixels) + ldb ,x ; is it graphics? + bpl LA8AC ; brif not - just blank the block + com GRBLOK ; invert pixel data + andb GRBLOK ; turn off the desired pixel + stb ,x ; put new pixel data on screen + rts +; Parse SET/RESET/POINT coordinates except for closing ) +LA8C1 jsr LB26A ; make sure it starts with ( +LA8C4 jsr RVEC21 ; do the RAM hook dance + jsr LB70B ; get first coordinate + cmpb #63 ; valid horizontal coordinate + bhi LA8D5 ; brif out of range + pshs b ; save horizontal coordinate + jsr LB738 ; look for , followed by vertical coordinate + cmpb #31 ; in range for vertical? +LA8D5 bhi LA948 ; brif not + pshs b ; save vertical coordinate + lsrb ; divide by two (two blocks per row) + lda #32 ; 32 bytes per row + mul ; now we have the offset into video RAM + ldx #VIDRAM ; point to start of screen + leax d,x ; now X points to the correct character row + ldb 1,s ; get horizontal coordinate + lsrb ; divide by two (two per character cell) + abx ; now we're pointing to the correct character cell + puls a,b ; get back coordinates (vertical in A) + anda #1 ; keep only row offset of vertical + rorb ; get column offset of horizontal to C + rola ; now we have "row * 2 + col" in A + ldb #0x10 ; make a bit mask (one bit left of first pixel) +LA8EE lsrb ; move mask right + deca ; at the right pixel? + bpl LA8EE ; brif not + stb GRBLOK ; save graphics block mask + rts +; POINT function +POINT bsr LA8C4 ; evaluate coordinates + ldb #0xff ; default colour value is -1 (not graphics) + lda ,x ; get character + bpl LA90A ; brif not graphics + anda GRBLOK ; is desired pixel set? + beq LA909 ; brif not - return 0 for "black" + ldb ,x ; get graphics data + lsrb ; shift right 4 to get colour in low bits + lsrb + lsrb + lsrb + andb #7 ; lose the graphics block bias +LA909 incb ; shift colours into 1 to 8 range +LA90A jsr LA5E8 ; convert B to floating point +LA90D jmp LB267 ; make sure we have a ) and return +; CLS command +CLS jsr RVEC22 ; do the RAM hook dance +LA913 beq LA928 ; brif no colour - just do a basic screen clear + jsr LB70B ; evaluate colour number + cmpb #8 ; valid colour? + bhi LA937 ; brif not - do the easter egg + tstb ; color 0? + beq LA925 ; brif so + decb ; normalize to 0 based colour numbers + lda #0x10 ; 16 blocks per colour + mul ; now we have the base code for that colour + orb #0x0f ; set all pixels +LA925 orb #0x80 ; make it a graphics block + skip2 +LA928 ldb #0x60 ; VDG screen space character + ldx #VIDRAM ; point to start of screen +LA92D stx CURPOS ; set cursor position +LA92F stb ,x+ ; blank a character + cmpx #VIDRAM+511 ; end of screen? + bls LA92F ; brif not + rts +LA937 bsr LA928 ; clear te screen + ldx #LA166-1 ; point to the easter egg + jmp LB99C ; go display it +; Evaluate an expression to B, prefixed by a comma, and do FC error if 0 +LA93F jsr LB26D ; force a comma +LA942 jsr LB70B ; evaluate expression to B + tstb ; is it 0? + bne LA984 ; brif not - return +LA948 jmp LB44A ; raise FC error +; SOUND command +SOUND bsr LA942 ; evaluate frequency + stb SNDTON ; save it + bsr LA93F ; evaluate duration (after a comma) +LA951 lda #4 ; constant factor for duration (each increment is 1/15 of a second) + mul + std SNDDUR ; save length of sound (IRQ will count it down) + lda PIA0+3 ; enable 60 Hz interrupt + ora #1 + sta PIA0+3 + clr ARYDIS ; clear array disable flag for some reason + bsr LA9A2 ; connect DAC to MUX output + bsr LA976 ; turn on sound +LA964 bsr LA985 ; store mid range output value and delay + lda #0xfe ; store high value and delay + bsr LA987 + bsr LA985 ; store mid range value and delay + lda #2 ; store low value and delay + bsr LA987 + ldx SNDDUR ; has timer expired? + bne LA964 ; brif not, do another wave +; Disable sound output +LA974 clra ; bit 3 to 0 will disable output + skip2 +; Enable sound output +LA976 lda #8 ; bit 3 set to enable output + sta ,-s ; save desired value + lda PIA1+3 ; get control register value + anda #0xf7 ; reset value + ora ,s+ ; set to desired value + sta PIA1+3 ; set new sound output status +LA984 rts +LA985 lda #0x7e ; mid range value for DAC +LA987 sta PIA1 ; set DAC output value + lda SNDTON ; get frequency +LA98C inca ; increment it (gives shorter count with higher values, so higher frequencies work) + bne LA98C ; brif not done yet + rts +; AUDIO command +AUDIO tfr a,b ; save ON/OFF token + jsr GETNCH ; munch the ON/OFF token + cmpb #0xaa ; OFF? + beq LA974 ; brif so + subb #0x88 ; ON? + jsr LA5C9 ; do SN error if not + incb ; now B is 1 - cassette sound source + bsr LA9A2 ; set MUX input to tape + bra LA976 ; enable sound +; Set MUX source to value in B +LA9A2 ldu #PIA0+1 ; point to PIA0 control register A + bsr LA9A7 ; program bit 0 then fall through for bit 1 +LA9A7 lda ,u ; get control register value + anda #0xf7 ; reset mux control bit + asrb ; shift desired value to C + bcc LA9B0 ; brif this bit is clear + ora #8 ; set the bit +LA9B0 sta ,u++ ; set register value and move to next register + rts +; IRQ service routine +BIRQSV lda PIA0+3 ; check for VSYNC interrupt + bpl LA9C5 ; brif not - return. BUG: should clear HSYNC interrupt status first + lda PIA0+2 ; clear VSYNC interrupt status + ldx >SNDDUR ; are we counting down for SOUND? (force extended in case DP is modified) + beq LA9C5 ; brif not + leax -1,x ; count down one tick + stx >SNDDUR ; save new count (forced extended in case DP is modified) +LA9C5 rti +; JOYSTK function +JOYSTK jsr LB70E ; evaluate which joystick axis is desired + cmpb #3 ; valid axis? + lbhi LB44A ; brif not + tstb ; want axis 0? + bne LA9D4 ; brif not + bsr GETJOY ; read axis data if axis 0 +LA9D4 ldx #POTVAL ; point to axis values + ldb FPA0+3 ; get desired axis + ldb b,x ; get axis value + jmp LB4F3 ; return value +; Read all four joystick axes. Note that this routine will try 10 times to get a value that matches +; the value obtained during the *previous call to this routine*. Thus, if the axis value has changed, +; this routine will do the read *ten times* before just returning the last value. This is assininely +; slow and probably a bug since it seems more logical to look for two matching reads in a row. Note +; also that this routine should be using PSHS and PULS but it doesn't. +GETJOY bsr LA974 ; turn off sound + ldx #POTVAL+4 ; point to the end of the axis data (we'll work backwards) + ldb #3 ; start with axis 3 +LA9E5 lda #10 ; 10 tries to see if we match *the last call* to this routine + std ,--s ; save retry counter and axis number + bsr LA9A2 ; set MUX for the correct axis +LA9EB ldd #0x4080 ; set initial trial value to mid range and the next difference to add/subtract to half +LA9EE sta ,-s ; store the add/subtract value + orb #2 ; keep rs232 output marking + stb PIA1 ; set DAC output to the trial value + eorb #2 ; remove RS232 output value + lda PIA0 ; read the comparator + bmi LA9FF ; brif comparator output is high (DAC is lower than the axis value) + subb ,s ; subtract next bit value (split the difference toward 0) + skip2 +LA9FF addb ,s ; add next bit value (split the different toward infinity) + lda ,s+ ; get bit value back + lsra ; cut in half + cmpa #1 ; have we done that last value for the DAC? + bne LA9EE ; brif not + lsrb ; normalize the axis value + lsrb + cmpb -1,x ; does it match the read from the last call to this routine? + beq LAA12 ; brif so + dec ,s ; are we out of retries? + bne LA9EB ; brif not - try again +LAA12 stb ,-x ; save new value and move pointer back + ldd ,s++ ; get axis counter and clean up retry counter + decb ; move to next axis + bpl LA9E5 ; brif still more axes to do + rts +; This is the "bottom half" of the character fetching routines. +BROMHK cmpa #'9+1 ; is it >= colon? + bhs LAA28 ; brif so Z set if colon, C clear. + cmpa #0x20 ; space? + bne LAA24 ; brif not + jmp GETNCH ; move on to another character if space +LAA24 suba #'0 ; normalize ascii digit to 0-9; we already handled above digit 9 + suba #-'0 ; this will cause a carry for any value that was already positive +LAA28 rts +; Jump table for functions +LAA29 fdb SGN ; SGN 0x80 + fdb INT ; INT 0x81 + fdb ABS ; ABS 0x82 + fdb USRJMP ; USR 0x83 + fdb RND ; RND 0x84 + fdb SIN ; SIN 0x85 + fdb PEEK ; PEEK 0x86 + fdb LEN ; LEN 0x87 + fdb STR ; STR$ 0x88 + fdb VAL ; VAL 0x89 + fdb ASC ; ASC 0x8a + fdb CHR ; CHR$ 0x8b + fdb EOF ; EOF 0x8c + fdb JOYSTK ; JOYSTK 0x8d + fdb LEFT ; LEFT$ 0x8e + fdb RIGHT ; RIGHT$ 0x8f + fdb MID ; MID$ 0x90 + fdb POINT ; POINT 0x91 + fdb INKEY ; INKEY$ 0x92 + fdb MEM ; MEM 0x93 +; Operator precedence and jump table (binary ops except relational) +LAA51 fcb 0x79 ; + + fdb LB9C5 + fcb 0x79 ; - + fdb LB9BC + fcb 0x7b ; * + fdb LBACC + fcb 0x7b ; / + fdb LBB91 + fcb 0x7f ; ^ (exponentiation) + fdb EXPJMP + fcb 0x50 ; AND + fdb LB2D5 + fcb 0x46 ; OR + fdb LB2D4 +; Reserved words table for commands +LAA66 fcs 'FOR' ; 0x80 + fcs 'GO' ; 0x81 + fcs 'REM' ; 0x82 + fcs "'" ; 0x83 + fcs 'ELSE' ; 0x84 + fcs 'IF' ; 0x85 + fcs 'DATA' ; 0x86 + fcs 'PRINT' ; 0x87 + fcs 'ON' ; 0x88 + fcs 'INPUT' ; 0x89 + fcs 'END' ; 0x8a + fcs 'NEXT' ; 0x8b + fcs 'DIM' ; 0x8c + fcs 'READ' ; 0x8d + fcs 'RUN' ; 0x8e + fcs 'RESTORE' ; 0x8f + fcs 'RETURN' ; 0x90 + fcs 'STOP' ; 0x91 + fcs 'POKE' ; 0x92 + fcs 'CONT' ; 0x93 + fcs 'LIST' ; 0x94 + fcs 'CLEAR' ; 0x95 + fcs 'NEW' ; 0x96 + fcs 'CLOAD' ; 0x97 + fcs 'CSAVE' ; 0x98 + fcs 'OPEN' ; 0x99 + fcs 'CLOSE' ; 0x9a + fcs 'LLIST' ; 0x9b + fcs 'SET' ; 0x9c + fcs 'RESET' ; 0x9d + fcs 'CLS' ; 0x9e + fcs 'MOTOR' ; 0x9f + fcs 'SOUND' ; 0xa0 + fcs 'AUDIO' ; 0xa1 + fcs 'EXEC' ; 0xa2 + fcs 'SKIPF' ; 0xa3 + fcs 'TAB(' ; 0xa4 + fcs 'TO' ; 0xa5 + fcs 'SUB' ; 0xa6 + fcs 'THEN' ; 0xa7 + fcs 'NOT' ; 0xa8 + fcs 'STEP' ; 0xa9 + fcs 'OFF' ; 0xaa + fcs '+' ; 0xab + fcs '-' ; 0xac + fcs '*' ; 0xad + fcs '/' ; 0xae + fcs '^' ; 0xaf + fcs 'AND' ; 0xb0 + fcs 'OR' ; 0xb1 + fcs '>' ; 0xb2 + fcs '=' ; 0xb3 + fcs '<' ; 0xb4 +; Reserved word list for functions +LAB1A fcs 'SGN' ; 0x80 + fcs 'INT' ; 0x81 + fcs 'ABS' ; 0x82 + fcs 'USR' ; 0x83 + fcs 'RND' ; 0x84 + fcs 'SIN' ; 0x85 + fcs 'PEEK' ; 0x86 + fcs 'LEN' ; 0x87 + fcs 'STR$' ; 0x88 + fcs 'VAL' ; 0x89 + fcs 'ASC' ; 0x8a + fcs 'CHR$' ; 0x8b + fcs 'EOF' ; 0x8c + fcs 'JOYSTK' ; 0x8d + fcs 'LEFT$' ; 0x8e + fcs 'RIGHT$' ; 0x8f + fcs 'MID$' ; 0x90 + fcs 'POINT' ; 0x91 + fcs 'INKEY$' ; 0x92 + fcs 'MEM' ; 0x93 +; Jump table for commands +LAB67 fdb FOR ; 0x80 FOR + fdb GO ; 0x81 GO + fdb REM ; 0x82 REM + fdb REM ; 0x83 ' + fdb REM ; 0x84 ELSE + fdb IFTOK ; 0x85 IF + fdb DATA ; 0x86 DATA + fdb PRINT ; 0x87 PRINT + fdb ON ; 0x88 ON + fdb INPUT ; 0x89 INPUT + fdb ENDTOK ; 0x8a END + fdb NEXT ; 0x8b NEXT + fdb DIM ; 0x8c DIM + fdb READ ; 0x8d READ + fdb RUN ; 0x8e RUN + fdb RESTOR ; 0x8f RESTORE + fdb RETURN ; 0x90 RETURN + fdb STOP ; 0x91 STOP + fdb POKE ; 0x92 POKE + fdb CONT ; 0x93 CONT + fdb LIST ; 0x94 LIST + fdb CLEAR ; 0x95 CLEAR + fdb NEW ; 0x96 NEW + fdb CLOAD ; 0x97 CLOAD + fdb CSAVE ; 0x98 CSAVE + fdb OPEN ; 0x99 OPEN + fdb CLOSE ; 0x9a CLOSE + fdb LLIST ; 0x9b LLIST + fdb SET ; 0x9c SET + fdb RESET ; 0x9d RESET + fdb CLS ; 0x9e CLS + fdb MOTOR ; 0x9f MOTOR + fdb SOUND ; 0xa0 SOUND + fdb AUDIO ; 0xa1 AUDIO + fdb EXEC ; 0xa2 EXEC + fdb SKIPF ; 0xa3 SKIPF +; Error message table +LABAF fcc 'NF' ; 0 NEXT without FOR + fcc 'SN' ; 1 Syntax error + fcc 'RG' ; 2 RETURN without GOSUB + fcc 'OD' ; 3 Out of data + fcc 'FC' ; 4 Illegal function call + fcc 'OV' ; 5 Overflow + fcc 'OM' ; 6 Out of memory + fcc 'UL' ; 7 Undefined line number + fcc 'BS' ; 8 Bad subscript + fcc 'DD' ; 9 Redimensioned array + fcc '/0' ; 10 Division by 0 + fcc 'ID' ; 11 Illegal direct statement + fcc 'TM' ; 12 Type mismatch + fcc 'OS' ; 13 Out of string space + fcc 'LS' ; 14 String too long + fcc 'ST' ; 15 String formula too complex + fcc 'CN' ; 16 Can't continue + fcc 'FD' ; 17 Bad file data + fcc 'AO' ; 18 File already open + fcc 'DN' ; 19 Device number error + fcc 'IO' ; 20 Input/output error + fcc 'FM' ; 21 Bad file mode + fcc 'NO' ; 22 File not open + fcc 'IE' ; 23 Input past end of file + fcc 'DS' ; 24 Direct statement in file +LABE1 fcn ' ERROR' +LABE8 fcn ' IN ' +LABED fcb 0x0d +LABEE fcc 'OK' + fcb 0x0d,0x00 +LABF2 fcb 0x0d + fcn 'BREAK' +; Search stack for a FOR/NEXT stack frame. Stop search when something that isn't a FOR/NEXT +; stack frame is found. Enter with the index variable descriptor pointer in VARDES, or NULL +; for the first match. +; +; NOTE: this routine can be reworked to avoid needed two temporaries by taking advantage of the +; 6809's registers. This requires some minor tweaks where the routine is called. Further, the +; use of B is completely pointless and, even if B is going to be used, why is it reloaded on +; every loop? +LABF9 leax 4,s ; skip past our caller and the main command loop return address +LABFB ldb #18 ; each FOR/NEXT frame is 18 bytes + stx TEMPTR ; save current search pointer + lda ,x ; get first byte of this frame + suba #0x80 ; set to 0 if FOR/NEXT + bne LAC1A ; brif not FOR/NEXT (we hit the end of the stack for a GOSUB frame) + ldx 1,x ; get index variable descriptor + stx TMPTR1 ; save it + ldx VARDES ; get desired index descriptor + beq LAC16 ; brif NULL - we found something + cmpx TMPTR1 ; does this one match? + beq LAC1A ; brif so + ldx TEMPTR ; get back frame pointer + abx ; move to next entry + bra LABFB ; check next block of data +LAC16 ldx TMPTR1 ; get index variable of this frame + stx VARDES ; set it as the one found +LAC1A ldx TEMPTR ; get matching frame pointer + tsta ; set Z if FOR/NEXT + rts +; This is a block copy routine which copies from top to bottom. It's not clear that the use of +; this routine actually saves any ROM space compared to just implementing the copies directly +; once all the marshalling to set up the parameter variables is taken into account. +LAC1E bsr LAC37 ; check to see if stack collides with D +LAC20 ldu V41 ; point to destination + leau 1,u ; offset for pre-dec + ldx V43 ; point to source + leax 1,x ; offset for pre-dec +LAC28 lda ,-x ; get source byte + pshu a ; store at destination (sta ,-u would be less weird) + cmpx V47 ; at the bottom of the copy? + bne LAC28 ; brif not + stu V45 ; save final destination address +LAC32 rts +; Check for 2*B (0 <= B <= 127) bytes for free memory +LAC33 clra ; zero extend + aslb ; times 2 (loses bit 7 of B) + addd ARYEND ; add to top of used memory +LAC37 addd #STKBUF ; add a fudge factor for interpreter operation + bcs LAC44 ; brif >65535! + sts BOTSTK ; get current stack pointer + cmpd BOTSTK ; is our new address above that? + blo LAC32 ; brif not - no error +LAC44 ldb #6*2 ; raise OM error +; The error servicing routine +LAC46 jsr RVEC16 ; do the RAM hook dance (ON ERROR reserved hook) +LAC49 jsr RVEC17 ; do the RAM hook dance again + jsr LA7E9 ; turn off tape + jsr LA974 ; disable sound + jsr LAD33 ; reset stack, etc. + clr DEVNUM ; reset output to screen + jsr LB95C ; do a newline + jsr LB9AF ; send a ? + ldx #LABAF ; point to error table + abx ; offset to correct message + bsr LACA0 ; send a char from X + bsr LACA0 ; send another char from X + ldx #LABE1-1 ; point to "ERROR" message +LAC68 jsr LB99C ; print ERROR message (or BREAK) + lda CURLIN ; are we in immediate mode? + inca + beq LAC73 ; brif not - go to immediate mode + jsr LBDC5 ; print "IN ****" +; This is the immediate mode loop +LAC73 jsr LB95C ; do a newline if needed +LAC76 ldx #LABEE-1 ; point to prompt (without leading CR) + jsr LB99C ; show prompt +LAC7C jsr LA390 ; read an input line + ldu #0xffff ; flag immediate mode + stu CURLIN + bcs LAC7C ; brif we ended on BREAK - just go for another line + tst CINBFL ; EOF? + lbne LA4BF ; brif so + stx CHARAD ; save start of input line as input pointer + jsr GETNCH ; get character from input line + beq LAC7C ; brif no input + bcs LACA5 ; brif numeric - adding or removing a line number + ldb #2*24 ; code for "direct statement in file" + tst DEVNUM ; keyboard input? + bne LAC46 ; brif not - complain about direct statement + jsr LB821 ; go tokenize the input line + jmp LADC0 ; go execute the newly tokenized line +LACA0 lda ,x+ ; get character and advance pointer + jmp LB9B1 ; output it +LACA5 jsr LAF67 ; convert line number to binary + ldx BINVAL ; get converted number + stx LINHDR ; put it before the line we just read + jsr LB821 ; tokenize the input line + stb TMPLOC ; save line length + bsr LAD01 ; find where the line should be in the program + bcs LACC8 ; brif the line number isn't already present + ldd V47 ; get address where the line is in the program + subd ,x ; get the difference between here and the end of the line (negative) + addd VARTAB ; subtract line length from the end of the program + std VARTAB ; save new end of program address + ldu ,x ; get start of next line +LACC0 pulu a ; get source byte (lda ,u+ would be less weird) + sta ,x+ ; move it down + cmpx VARTAB ; have we moved everything yet? + bne LACC0 ; brif not +LACC8 lda LINBUF ; see if there is actually a line to input + beq LACE9 ; brif not - we just needed to remove the line + ldd VARTAB ; get current end of program + std V43 ; set as source pointer + addb TMPLOC ; add in the length of the new line + adca #0 + std V41 ; save destination pointer + jsr LAC1E ; make sure there's enough room and then make a hole for the new line + ldu #LINHDR-2 ; point to the line (well, 4 bytes before it, incl line number and fake next line pointer) +LACDD pulu a ; get byte from new line (lda ,u+ would be less weird) + sta ,x+ ; stow it + cmpx V45 ; at the end of the hole we just made? + bne LACDD ; brif not + ldx V41 ; get save new top of program address + stx VARTAB +LACE9 bsr LAD21 ; reset variables, etc. + bsr LACEF ; adjust next line pointers + bra LAC7C ; go read another input line +; Recompute next line pointers +LACEF ldx TXTTAB ; point to start of program +LACF1 ldd ,x ; get address of next line + beq LAD16 ; brif end of program + leau 4,x ; move past pointer and line number +LACF7 lda ,u+ ; are we at the end of the line? + bne LACF7 ; brif not + stu ,x ; save new next line pointer + ldx ,x ; point to next line + bra LACF1 ; process the next line +; Find a line in the program +LAD01 ldd BINVAL ; get desired line number + ldx TXTTAB ; point to start of program +LAD05 ldu ,x ; get address of next line + beq LAD12 ; brif end of program + cmpd 2,x ; do we have a match? + bls LAD14 ; brif our search number is <= the number here + ldx ,x ; move to next line + bra LAD05 ; check another line +LAD12 orcc #1 ; set C for not found +LAD14 stx V47 ; save address of matching line *or* line just after where it would have been +LAD16 rts +; NEW command +; This routine has multiple entry points used for various "levels" of NEW +NEW bne LAD14 ; brif there was input given; should be LAD16! +LAD19 ldx TXTTAB ; point to start of program + clr ,x+ ; blank out program (with NULL next line pointer) + clr ,x+ + stx VARTAB ; save end of program +LAD21 ldx TXTTAB ; get start of program + jsr LAEBB ; put input pointer there +LAD26 ldx MEMSIZ ; reset string space + stx STRTAB + jsr RESTOR ; reset DATA pointer + ldx VARTAB ; clear out scalars and arrays + stx ARYTAB + stx ARYEND +LAD33 ldx #STRSTK ; reset the string stack + stx TEMPPT + ldx ,s ; get return address (we're going to reset the stack) + lds FRETOP ; reset the stack to top of memory + clr ,-s ; put stopper so FOR/NEXT search will actually stop here + clr OLDPTR ; reset "CONT" state + clr OLDPTR+1 + clr ARYDIS ; un-disable arrays + jmp ,x ; return to original caller +; FOR command +FOR lda #0x80 ; disable array parsing + sta ARYDIS + jsr LET ; assign start value to index + jsr LABF9 ; search stack for matching FOR/NEXT frame + leas 2,s ; lose return address + bne LAD59 ; brif variable not already being used + ldx TEMPTR ; get address of matched data + leas b,x ; move stack pointer to the end of it (B is set to 18 in the stack search) +LAD59 ldb #9 ; is there room for 18 bytes in memory? + jsr LAC33 + jsr LAEE8 ; get address of the end of this statement in X + ldd CURLIN ; get line number + pshs x,b,a ; save next line address and current line number + ldb #0xa5 ; make sure we have TO + jsr LB26F + jsr LB143 ; make sure we have a numeric index + jsr LB141 ; evaluate terminal condition value + ldb FP0SGN ; pack FPA0 in place + orb #0x7f + andb FPA0 + stb FPA0 + ldy #LAD7F ; where to come back to + jmp LB1EA ; stash terminal condition on the stack +LAD7F ldx #LBAC5 ; point to FP 1.0 (default step) + jsr LBC14 ; unpack it to FPA0 + jsr GETCCH ; get character after the terminal + cmpa #0xa9 ; is it STEP? + bne LAD90 ; brif not + jsr GETNCH ; eat STEP + jsr LB141 ; evaluate step condition +LAD90 jsr LBC6D ; get "status" of FPA0 + jsr LB1E6 ; stash FPA0 on the stack (for step value) + ldd VARDES ; get variable descriptor pointer + pshs d ; put that on the stack too + lda #0x80 ; flag the frame as a FOR/NEXT frame + pshs a +; Main command interpretation loop +LAD9E jsr RVEC20 ; do the RAM hook dance + andcc #0xaf ; make sure interrupts are running + bsr LADEB ; check for BREAK/pause + ldx CHARAD ; get input pointer + stx TINPTR ; save input pointer for start of line + lda ,x+ ; get current input character + beq LADB4 ; brif end of line - move to another line + cmpa #': ; end of statement? + beq LADC0 ; brif so - keep processing +LADB1 jmp LB277 ; raise a syntax error +LADB4 lda ,x++ ; get MSB of next line pointer and skip past pointer + sta ENDFLG + beq LAE15 ; brif MSB of next line address is 0 (do END) + ldd ,x+ ; get line number but only advance one + std CURLIN ; set current line number + stx CHARAD ; set input pointer to one before line text +LADC0 jsr GETNCH ; move past statement separator or to first character in line + bsr LADC6 ; process a command + bra LAD9E ; handle next statement or line +LADC6 beq LAE40 ; return if end of statement + tsta ; is it a token? + lbpl LET ; brif not - do a LET + cmpa #0xa3 ; above SKIPF? + bhi LADDC ; brif so + ldx COMVEC+3 ; point to jump table + lsla ; two bytes per entry (loses the token bias) + tfr a,b ; put it in B for unsigned ABX + abx + jsr GETNCH ; move past token + jmp [,x] ; transfer control to the handler (which will return to the main loop) +LADDC cmpa #0xb4 ; is it a non-executable token? + bls LADB1 ; brif so + jmp [COMVEC+13] ; transfer control to ECB command handler +; RESTORE command +RESTOR ldx TXTTAB ; point to beginning of the program + leax -1,x ; move back one (to compensate for "GETNCH") +LADE8 stx DATPTR ; save as new data pointer + rts +; BREAK check +LADEB jsr LA1C1 ; read keyboard + beq LADFA ; brif no key down +LADF0 cmpa #3 ; BREAK? + beq STOP ; brif so - do a STOP + cmpa #0x13 ; pause (SHIFT-@)? + beq LADFB ; brif so + sta IKEYIM ; cache key for later INKEY$ so break check doesn't break INKEY$ +LADFA rts +LADFB jsr KEYIN ; read keyboard + beq LADFB ; brif no key down + bra LADF0 ; process pressed key in case BREAK or SHIFT-@ again +; END command +ENDTOK jsr LA426 ; close files + jsr GETCCH ; re-get input character + bra LAE0B +; STOP command +STOP orcc #1 ; flag "STOP" +LAE0B bne LAE40 ; brif not end of statement + ldx CHARAD ; save current input pointer + stx TINPTR +LAE11 ror ENDFLG ; save END/STOP flag (C) + leas 2,s ; lose return address +LAE15 ldx CURLIN ; get current input line (end of program comes here) + cmpx #0xffff ; immediate mode? + beq LAE22 ; brif so + stx OLDTXT ; save line where we stopped executing + ldx TINPTR ; get input pointer + stx OLDPTR ; save location where we stopped executing +LAE22 clr DEVNUM ; reset to screen/keyboard + ldx #LABF2-1 ; point to BREAK message + tst ENDFLG ; are we doing "BREAK"? + lbpl LAC73 ; brif not + jmp LAC68 ; go do the BREAK message and return to main loop +; CONT command +CONT bne LAE40 ; brif not end of statement + ldb #2*16 ; code for can't continue + ldx OLDPTR ; get saved execution pointer + lbeq LAC46 ; brif no saved pointer - raise CN error + stx CHARAD ; reset input pointer + ldx OLDTXT ; reset current line number + stx CURLIN +LAE40 rts +; CLEAR command +CLEAR beq LAE6F ; brif no argument + jsr LB3E6 ; evaluate string space size + pshs d ; save it + ldx MEMSIZ ; get memory size (top of memory) + jsr GETCCH ; is there anything after the string space size? + beq LAE5A ; brif not + jsr LB26D ; force a comma + jsr LB73D ; get top of memory value in X + leax -1,x ; move back one (top of cleared space) + cmpx TOPRAM ; is it within the memory available? + bhi LAE72 ; brif higher than top of memory - OM error +LAE5A tfr x,d ; so we can do math for checking memory usage + subd ,s++ ; subtract out string space value + bcs LAE72 ; brif less than 0 + tfr d,u ; U is bottom of cleared space + subd #STKBUF ; also account for slop space + bcs LAE72 ; brif less than 0 + subd VARTAB ; is there still room for the program? + blo LAE72 ; brif not + stu FRETOP ; set top of free memory + stx MEMSIZ ; set size of usable memory +LAE6F jmp LAD26 ; erase variables, etc. +LAE72 jmp LAC44 ; raise OM error +; RUN command +RUN jsr RVEC18 ; do the RAM hook dance + jsr LA426 ; close any open files + jsr GETCCH ; is there a line number + lbeq LAD21 ; brif no line number - start from beginning + jsr LAD26 ; clear variables, etc. + bra LAE9F ; "GOTO" the line number +; GO command (GOTO and GOSUB) +GO tfr a,b ; save TO/SUB +LAE88 jsr GETNCH ; eat the TO/SUB token + cmpb #0xa5 ; TO? + beq LAEA4 ; brif GOTO + cmpb #0xa6 ; SUB? + bne LAED7 ; brif not + ldb #3 ; room for 6 bytes? + jsr LAC33 + ldu CHARAD ; get input pointer + ldx CURLIN ; get line number + lda #0xa6 ; flag for GOSUB frame + pshs u,x,a ; set stack frame +LAE9F bsr LAEA4 ; do "GOTO" + jmp LAD9E ; go back to main loop +; Actual GOTO is here +LAEA4 jsr GETCCH ; get current input + jsr LAF67 ; convert number to binary + bsr LAEEB ; move input pointer to end of statement + leax 1,x ; point to start of next line + ldd BINVAL ; get desired line number + cmpd CURLIN ; is it beyond here? + bhi LAEB6 ; brif so + ldx TXTTAB ; start search at beginning of program +LAEB6 jsr LAD05 ; find line number + bcs LAED2 ; brif not found +LAEBB leax -1,x ; move to just before start of line + stx CHARAD ; reset input pointer +LAEBF rts +; RETURN command +RETURN bne LAEBF ; exit if argument given + lda #0xff ; set VARDES to an illegal value so we ignore FOR frames + sta VARDES + jsr LABF9 ; look for a GOSUB frame + tfr x,s ; reset stack + cmpa #0xa6-0x80 ; is it a GOSUB frame? + beq LAEDA ; brif so + ldb #2*2 ; code for RETURN without GOSUB + skip2 +LAED2 ldb #7*2 ; code for undefined line number + jmp LAC46 ; raise error +LAED7 jmp LB277 ; raise syntax error +LAEDA puls a,x,u ; get back saved line number and input pointer + stx CURLIN ; reset line number + stu CHARAD ; reset input pointer +; DATA command +DATA bsr LAEE8 ; move input pointer to end of statement + skip2 +; REM command (also ELSE) +REM bsr LAEEB ; move input pointer to end of line + stx CHARAD ; save new input pointer +LAEE7 rts +; Return end of statement (LAEE8) or line (AEEB) in X +LAEE8 ldb #': ; colon is statement terminator + skip1lda +LAEEB clrb ; make main terminator NUL + stb CHARAC ; save terminator + clrb ; end of line - always terminates + ldx CHARAD ; get input pointer +LAEF1 tfr b,a ; save secondary terminator + ldb CHARAC ; get main terminator + sta CHARAC ; save secondary +LAEF7 lda ,x ; get input character + beq LAEE7 ; brif end of line + pshs b ; save terminator + cmpa ,s+ ; does it match? + beq LAEE7 ; brif so - bail + leax 1,x ; move pointer ahead + cmpa #'" ; start of string? + beq LAEF1 ; brif so + inca ; functon token? + bne LAF0C ; brif not + leax 1,x ; skip second part of function token +LAF0C cmpa #0x85+1 ; IF? + bne LAEF7 ; brif not + inc IFCTR ; bump "IF" count + bra LAEF7 ; get check another input character +; IF command +IFTOK jsr LB141 ; evaluate condition + jsr GETCCH ; find out what's after the conditin + cmpa #0x81 ; GO? + beq LAF22 ; treat same as THEN + ldb #0xa7 ; make sure we have a THEN + jsr LB26F +LAF22 lda FP0EXP ; get true/false (false is 0) + bne LAF39 ; brif condition true + clr IFCTR ; reset IF counter +LAF28 bsr DATA ; skip over statement + tsta ; end of line? + beq LAEE7 ; brif so + jsr GETNCH ; get start of this statement + cmpa #0x84 ; ELSE? + bne LAF28 ; brif not + dec IFCTR ; is it a matching ELSE? + bpl LAF28 ; brif not - keep looking + jsr GETNCH ; eat the ELSE +LAF39 jsr GETCCH ; get current input + lbcs LAEA4 ; brif numeric - to a GOTO + jmp LADC6 ; let main loop interpret the next command +; ON command +ON jsr LB70B ; evaluate index expression +LAF45 ldb #0x81 ; make sure we have "GO" + jsr LB26F + pshs a ; save TO/SUB + cmpa #0xa6 ; SUB? + beq LAF54 ; brif so + cmpa #0xa5 ; TO? +LAF52 bne LAED7 ; brif not +LAF54 dec FPA0+3 ; are we at the right index? + bne LAF5D ; brif not + puls b ; get TO/SUB token + jmp LAE88 ; go do GOTO or GOSUB +LAF5D jsr GETNCH ; munch a character + bsr LAF67 ; parse line number + cmpa #', ; is there another line following? + beq LAF54 ; brif so - see if we're there yet + puls b,pc ; clean up TO/SUB token and return - we fell through +; Parse a line number +LAF67 ldx ZERO ; initialize line number accumulator to 0 + stx BINVAL +LAF6B bcc LAFCE ; brif not numeric + suba #'0 ; adjust to actual value of digit + sta CHARAC ; save digit + ldd BINVAL ; get accumulated number + cmpa #24 ; will this overflow? + bhi LAF52 ; brif so - raise syntax error + aslb ; times 2 + rola + aslb ; times 4 + rola + addd BINVAL ; times 5 + aslb ; times 10 + rola + addb CHARAC ; add in digit + adca #0 + std BINVAL ; save new accumulated number + jsr GETNCH ; fetch next character + bra LAF6B ; process next digit +; LET command (the LET keyword requires Extended Basic) +LET jsr LB357 ; evaluate destination variable + stx VARDES ; save descriptor pointer + ldb #0xb3 ; make sure we have = + jsr LB26F + lda VALTYP ; get destination variable type + pshs a ; save it for later + jsr LB156 ; evaluate the expression to assign + puls a ; get back original variable type + rora ; put type in C + jsr LB148 ; make sure the current result matches the type + lbeq LBC33 ; bri fnumeric - copy FPA0 to variable +LAFA4 ldx FPA0+2 ; point to descriptor of replacement string + ldd FRETOP ; get bottom of string space + cmpd 2,x ; is the string already in string space? + bhs LAFBE ; brif so + cmpx VARTAB ; is the descriptor in variable space? + blo LAFBE ; brif not +LAFB1 ldb ,x ; get length of string + jsr LB50D ; allocate space for this string + ldx V4D ; get descriptor pointer back + jsr LB643 ; copy string into string space + ldx #STRDES ; point to temporary string descriptor +LAFBE stx V4D ; save descriptor pointer + jsr LB675 ; remove string from string stack if appropriate + ldu V4D ; get back replacement descriptor + ldx VARDES ; get target descriptor + pulu a,b,y ; get string length (A) and data pointer (Y) + sta ,x ; save new length + sty 2,x ; save new pointer +LAFCE rts +; READ and INPUT commands. +LAFCF fcc '?REDO' ; The ?REDO message + fcb 0x0d,0x00 +LAFD6 ldb #2*17 ; bad file data code + tst DEVNUM ; are we reading from the keyboard? + beq LAFDF ; brif so +LAFDC jmp LAC46 ; raise the error +LAFDF lda INPFLG ; are we doing INPUT? + beq LAFEA ; brif so + ldx DATTXT ; get line number where the DATA statement happened + stx CURLIN ; set current line number to that so can report the correct location + jmp LB277 ; raise a syntax error on bad data +LAFEA ldx #LAFCF-1 ; show the ?REDO if we're doing INPUT + jsr LB99C + ldx TINPTR ;* reset input pointer to start of statement (this will cause the + stx CHARAD ;* INPUT statement to be re-executed + rts +INPUT ldb #11*2 ; code for illegal direct statement + ldx CURLIN ; are we in immediate mode? + leax 1,x + beq LAFDC ; brif so - raise ID error + bsr LB002 ; go do the INPUT thing + clr DEVNUM ; reset device to screen/keyboard + rts +LB002 cmpa #'# ; is there a device number? + bne LB00F ; brif not + jsr LA5A5 ; parse device number + jsr LA3ED ; make sure it's valid for input + jsr LB26D ; make sure we have a comma after the device number +LB00F cmpa #'" ; is there a prompt string? + bne LB01E ; brif not + jsr LB244 ; parse the prompt string + ldb #'; ; make sure we have a semicolon after the prompt + jsr LB26F + jsr LB99F ; print the prompt +LB01E ldx #LINBUF ; point to line input buffer + clr ,x ; NUL first byte to indicate no data + tst DEVNUM ; is it keyboard input? + bne LB049 ; brif not + bsr LB02F ; read a line from the keyboard + ldb #', ; put a comma at the start of the buffer + stb ,x + bra LB049 ; go process some input +LB02F jsr LB9AF ; send a ? + jsr LB9AC ; send a space +LB035 jsr LA390 ; read input from the keyboard + bcc LB03F ; brif not BREAK + leas 4,s ; clean up stack +LB03C jmp LAE11 ; go process BREAK +LB03F ldb #2*23 ; input past end of file error code + tst CINBFL ; was it EOF? + bne LAFDC ; brif so - raise the error + rts +READ ldx DATPTR ; fetch current DATA pointer + skip1lda ; set A to nonzero (for READ) +LB049 clra ; set A to zero (for INPUT) + sta INPFLG ; record whether we're doing READ or INPUT + stx DATTMP ; save current input location +LB04E jsr LB357 ; evaluate a variable (destination of data) + stx VARDES ; save descriptor + ldx CHARAD ; save interpreter input pointer + stx BINVAL + ldx DATTMP ; get data pointer + lda ,x ; is there anything to read? + bne LB069 ; brif so + lda INPFLG ; is it INPUT? + bne LB0B9 ; brif not + jsr RVEC10 ; do the RAM hook dance + jsr LB9AF ; send a ? (so subsequent lines get ??) + bsr LB02F ; go read an input line +LB069 stx CHARAD ; save data pointer + jsr GETNCH ; fetch next data character + ldb VALTYP ; do we want a number? + beq LB098 ; brif so + ldx CHARAD ; get input pointer + sta CHARAC ; save initial character as the delimiter + cmpa #'" ; do we have a string delimiter? + beq LB08B ; brif so - use " as both delimiters + leax -1,x ; back up input if we don't have a delimiter + clra ; set delimiter to NUL (end of line) + sta CHARAC + jsr LA35F ; set up print parameters + tst PRTDEV ; is it a file type device? + bne LB08B ; brif so - use two NULs + lda #': ; use colon as one delimiter + sta CHARAC + lda #', ; and use comma as the other +LB08B sta ENDCHR ; save second terminator + jsr LB51E ; parse out the string + jsr LB249 ; move input pointer past the string + jsr LAFA4 ; assign the string to the variable + bra LB09E ; go see if there's more to read +LB098 jsr LBD12 ; parse a numeric string + jsr LBC33 ; assign the numbe to the variable +LB09E jsr GETCCH ; get current input character + beq LB0A8 ; brif end of line + cmpa #', ; check for comma + lbne LAFD6 ; brif not - we have bad data +LB0A8 ldx CHARAD ; get current data pointer + stx DATTMP ; save the data pointer + ldx BINVAL ; restore the interpreter input pointer + stx CHARAD + jsr GETCCH ; get current input from program + beq LB0D5 ; brif end of statement + jsr LB26D ; make sure there's a comma between variables + bra LB04E ; go read another item +LB0B9 stx CHARAD ; reset input pointer + jsr LAEE8 ; search for end of statement + leax 1,x ; move past end of statement + tsta ; was it end of line? + bne LB0CD ; brif not + ldb #2*3 ; code for out of data + ldu ,x++ ; get pointer to next line + beq LB10A ; brif end of program - raise OD error + ldd ,x++ ; get line number + std DATTXT ; record it for raising errors in DATA statements +LB0CD lda ,x ; do we have a DATA statement? + cmpa #0x86 + bne LB0B9 ; brif not - keep scanning + bra LB069 ; go process the input +LB0D5 ldx DATTMP ; get data pointer + ldb INPFLG ; were we doing READ? + lbne LADE8 ; brif so - save DATA pointer + lda ,x ; is there something after the input in the input buffer? + beq LB0E7 ; brif not - we consumed everything + ldx #LB0E8-1 ; print the ?EXTRA IGNORED message + jmp LB99C +LB0E7 rts +LB0E8 fcc '?EXTRA IGNORED' + fcb 0x0d,0x00 +; NEXT command +NEXT bne LB0FE ; brif argument given + ldx ZERO ; set to NULL descriptor pointer + bra LB101 ; go process "any index will do" +LB0FE jsr LB357 ; evaluate the variable +LB101 stx VARDES ; save the index we're looking for + jsr LABF9 ; search the stack for the matching frame + beq LB10C ; brif we found a matching frame + ldb #0 ; code for NEXT without FOR +LB10A bra LB153 ; raise the error +LB10C tfr x,s ; reset the stack to the start of the stack frame + leax 3,x ; point to the STEP value + jsr LBC14 ; copy the value to FPA0 + lda 8,s ; get step direction + sta FP0SGN ; save as sign of FPA0 + ldx VARDES ; point to index variable + jsr LB9C2 ; add (X) to FPA0 (steps the index) + jsr LBC33 ; save new value to the index + leax 9,s ; point to terminal condition + jsr LBC96 ; compare the new index value with the terminal + subb 8,s ; set B=0 if we hit the terminal (or passed it with nonzero step) + beq LB134 ; brif loop complete + ldx 14,s ; restore line number and input pointer to start of loop + stx CURLIN + ldx 16,s + stx CHARAD +LB131 jmp LAD9E ; return to interpretation loop +LB134 leas 18,s ; remove the frame from the stack + jsr GETCCH ; get character after the index + cmpa #', ; do we have more indexes? + bne LB131 ; brif not + jsr GETNCH ; munch the comma + bsr LB0FE ; go process another value +; NOTE: despite the BSR on the preceding line, execution of the NEXT command will not fall +; through this point, nor will the stack grow without bound. The BSR is required to make sure +; the stack is aligned properly for the stack search for the subsequent index variable. +; +; The following is the expression evaluation system. It has various entry points including for type +; checking. This really consists of two co-routines, one for evaluating operators and one for individual +; terms. However, it does some rather confusing stack operations so it's a bit difficult to follow +; just how some of this works. +; +; Evaluate numeric expression +LB141 bsr LB156 ; evaluate an expression +; TM error if string +LB143 andcc #0xfe ; clear C to indicate we want a number + skip2keepc +; TM error if numeric +LB146 orcc #1 ; set C to indicate we want a string +; TM error if: C = 1 and number, OR C = 0 and string +LB148 tst VALTYP ; set flags on the current value to (doesn't change C) + bcs LB14F ; brif we want a string + bpl LB0E7 ; brif we have a number (we want a number) + skip2 +LB14F bmi LB0E7 ; brif we have a string (we want a string) +LB151 ldb #12*2 ; code for TM error +LB153 jmp LAC46 ; raise the error +; The general expression evaluation entry point +LB156 bsr LB1C6 ; back up input pointer to compensate for GETNCH below +LB158 clra ; set operator precedence to 0 (no previous operator) + skip2 +LB15A pshs b ; save relational operator flags + pshs a ; save previous operator precedence + ldb #1 ; make sure we aren't overflowing the stack + jsr LAC33 + jsr LB223 ; go evaluate the first term +LB166 clr TRELFL ; flag no relational operators seen +LB168 jsr GETCCH ; get input character +LB16A suba #0xb2 ; token for > (lowest relational operator) + blo LB181 ; brif below relational operators + cmpa #3 ; there are three relational operators, is it one? + bhs LB181 ; brif not + cmpa #1 ; set C if > + rola ; shift C into bit 0 (4: <, 2: =, 1: >) + eora TRELFL ; flip the bit for this operator + cmpa TRELFL ; did the result get lower? + blo LB1DF ; brif so - we have a duplicate so raise an error + sta TRELFL ; save new operator flags + jsr GETNCH ; munch the operator + bra LB16A ; go see if we have another one +LB181 ldb TRELFL ; do we have a relational comparison? + bne LB1B8 ; brif so + lbcc LB1F4 ; brif the token is above the relational operators + adda #7 ; put operators starting at 0 + bhs LB1F4 ; brif we're above 0 - it's an operator, Jim + adca VALTYP ; add carry, numeric flag, and modified token number + lbeq LB60F ; brif we have string and A is + - do concatenation + adca #-1 ; restore operator number + pshs a ; save operator number + asla ; times 2 + adda ,s+ ; and times 3 (3 bytes per entry) + ldx #LAA51 ; point to operator pecedence and jump table + leax a,x ; point to correct entry +LB19F puls a ; get precedence of previous operation + cmpa ,x ; is hit higher (or same) than the current one? + bhs LB1FA ; brif so - we need to process that operator + bsr LB143 ; TM error if we have a string +LB1A7 pshs a ; save previous operation precedence + bsr LB1D4 ; push operator handler address and FPA0 onto the stack + ldx RELPTR ; get pointer to arithmetic/logical table entry for last operation + puls a ; get back precedence + bne LB1CE ; brif we had a relational operation + tsta ; check precedence of previous operation + lbeq LB220 ; brif end of expression + bra LB203 ; go handle operation +LB1B8 asl VALTYP ; get type of value to C + rolb ; mix it in to bit 0 of relational flags + bsr LB1C6 ; back up input pointer + ldx #LB1CB ; point to relational operator precedence and handler + stb TRELFL ; save relational comparison flags + clr VALTYP ; result will be numeric + bra LB19F ; to process the operation +LB1C6 ldx CHARAD ; get input pointer + jmp LAEBB ; back it up one and put it back +LB1CB fcb 0x64 ; precedence of relational comparison + fdb LB2F4 ; handler address for relational comparison +LB1CE cmpa ,x ; is last done operation higher (or same) precedence? + bhs LB203 ; brif so - go process it + bra LB1A7 ; go push things on the stack and process this operation otherwise +LB1D4 ldd 1,x ; get address of operatorroutine + pshs d ; save it + bsr LB1E2 ; push FPA0 onto the stack + ldb TRELFL ; get back relational operator flags + lbra LB15A ; go evaluate another operation +LB1DF jmp LB277 ; raise a syntax error +LB1E2 ldb FP0SGN ; get sign of FPA0 + lda ,x ; get precedence of this operation +LB1E6 puls y ; get back original caller + pshs b ; save sign +LB1EA ldb FP0EXP ; get exponent + ldx FPA0 ; get mantissa + ldu FPA0+2 + pshs u,x,b ; stow FPA0 sign and mantissa + jmp ,y ; return to caller +LB1F4 ldx ZERO ; point to dummy value + lda ,s+ ; get precedence of previous operation (and set flags) + beq LB220 ; brif end of expression +LB1FA cmpa #0x64 ; relational operation? + beq LB201 ; brif so + jsr LB143 ; type mismatch if string +LB201 stx RELPTR ; save pointer to operator routine +LB203 puls b ; get relational flags + cmpa #0x5a ; NOT operation? + beq LB222 ; brif so (it was unary) + cmpa #0x7d ; unary negation? + beq LB222 ; brif so + lsrb ; shift value type flag out of relational flags + stb RELFLG ; save relational operator flag + puls a,x,u ; get FP value back + sta FP1EXP ; set exponent and mantissa in FPA1 + stx FPA1 + stu FPA1+2 + puls b ; and the sign + stb FP1SGN + eorb FP0SGN ; set RESSGN if the two operand signs differ + stb RESSGN +LB220 ldb FP0EXP ; get exponent of FPA0 +LB222 rts ; return or transfer control to operator handler routine +LB223 jsr RVEC15 ; do the RAM hook dance + clr VALTYP ; set type to numeric + jsr GETNCH ; get first character in the term + bcc LB22F ; brif not numeric +LB22C jmp LBD12 ; parse a number (and return) +LB22F jsr LB3A2 ; set carry if not alpha + bcc LB284 ; brif alpha character (variable) + cmpa #'. ; decimal point? + beq LB22C ; brif so - evaluate number + cmpa #0xac ; minus? + beq LB27C ; brif so - process unary negation + cmpa #0xab ; plus? + beq LB223 ; brif so - ignore unary "posation" + cmpa #'" ; string delimiter? + bne LB24E ; brif not +LB244 ldx CHARAD ; get input pointer + jsr LB518 ; go parse the string +LB249 ldx COEFPT ; get address of end of string + stx CHARAD ; move input pointer past string + rts +LB24E cmpa #0xa8 ; NOT? + bne LB25F ; brif not + lda #0x5a ; precedence of unary NOT + jsr LB15A ; process the operand of NOT + jsr INTCNV ; convert to integer in D + coma ; do a bitwise complement + comb + jmp GIVABF ; resturn the result +LB25F inca ; is it a function token? + beq LB290 ; brif so +LB262 bsr LB26A ; only other legal thing must be a (expr) + jsr LB156 ; evaluate parentheticized expression +LB267 ldb #') ; force a ) + skip2 +LB26A ldb #'( ; force a ( + skip2 +LB26D ldb #', ; force a , +LB26F cmpb [CHARAD] ; does character match? + bne LB277 ; brif not + jmp GETNCH ; each the character and return the next +LB277 ldb #2*1 ; raise syntax error + jmp LAC46 +LB27C lda #0x7d ; unary negation precedence + jsr LB15A ; evaluate argument + jmp LBEE9 ; flip sign of FPA0 and return +LB284 jsr LB357 ; evaluate variable +LB287 stx FPA0+2 ; save descriptor address in FPA0 + lda VALTYP ; test variable type + bne LB222 ; brif string - we're done + jmp LBC14 ; copy FP number from (X) into FPA0 +LB290 jsr GETNCH ; get the actual token number + tfr a,b ; save it (for offsetting X) + lslb ; two bytes per jump table entry (and lose high bit) + jsr GETNCH ; eat the token byte + cmpb #2*19 ; is it a valid token for Color Basic? + bls LB29F ; brif so + jmp [COMVEC+18] ; transfer control to Extended Basic if not +LB29F pshs b ; save jump table offset + cmpb #2*14 ; does it expect a numeric argument? + blo LB2C7 ; brif so + cmpb #2*18 ; does it need no arguments? + bhs LB2C9 ; brif so + bsr LB26A ; force a ( + lda ,s ; get token value + cmpa #2*17 ; is it POINT? + bhs LB2C9 ; brif so + jsr LB156 ; evaluate first argument string + bsr LB26D ; force a comma + jsr LB146 ; TM error if string + puls a ; get token value + ldu FPA0+2 ; get string descriptor + pshs u,a ; now we save the first string argument and the token value + jsr LB70B ; evaluate first numeric argument + puls a ; get back token value + pshs b,a ; save second argument and token value + fcb 0x8e ; opcode of LDX immediate (skips two bytes) +LB2C7 bsr LB262 ; force a ( +LB2C9 puls b ; get offset + ldx COMVEC+8 ; get jump table pointer + abx ; add offset into table + jsr [,x] ; go process function + jmp LB143 ; make sure result is numeric +; operator OR +LB2D4 skip1lda ; set flag to nonzero to signal OR +; operator AND +LB2D5 clra ; set flag to zero to signal AND + sta TMPLOC ; save AND/OR flag + jsr INTCNV ; convert second argument to intenger + std CHARAC ; save it + jsr LBC4A ; move first argument to FPA0 + jsr INTCNV ; convert first argument to integer + tst TMPLOC ; is it AND or OR? + bne LB2ED ; brif OR + anda CHARAC ; do the bitwise AND + andb ENDCHR + bra LB2F1 ; finish up +LB2ED ora CHARAC ; do the bitwise OR + orb ENDCHR +LB2F1 jmp GIVABF ; return integer result +; relational comparision operators +LB2F4 jsr LB148 ; TM error if type mismatch + BNE LB309 ; brif we have a string comparison + lda FP1SGN ; pack FPA1 + ora #0x7f + anda FPA1 + sta FPA1 + ldx #FP1EXP ; point to packed FPA1 + jsr LBC96 ; compare FPA0 to FPA1 + bra LB33F ; handle truth comparison +LB309 clr VALTYP ; the result of a comparison is always a number + dec TRELFL ; remove the string flag from the comparison data + jsr LB657 ; get string details for second argument + stb STRDES ; save them in the temporary string descriptor + stx STRDES+2 + ldx FPA1+2 ; get pointer to first argument descriptor + jsr LB659 ; get string details for second argument + lda STRDES ; get length of second argument + pshs b ; save length of first argument + suba ,s+ ; now A is the difference in string lengths + beq LB328 ; brif string lengths are equal + lda #1 ; flag for second argument is longer than first + bcc LB328 ; brif second string is longer than first + ldb STRDES ; get length of second string (shorter) + nega ; invert default comparison result +LB328 sta FP0SGN ; save default truth flag + ldu STRDES+2 ; get pointer to start of second string + incb ; compensate for DECB +LB32D decb ; have we compared everything? + bne LB334 ; brif not + ldb FP0SGN ; get default truth value + bra LB33F ; decide comparison truth +LB334 lda ,x+ ; get byte from first argument + cmpa ,u+ ; compare with second argument + beq LB32D ; brif equal - keep comparing + ldb #0xff ; negative if first string is > second + bcc LB33F ; brif string A > string B + negb ; invert result +LB33F addb #1 ; convert to 0,1,2 + rolb ; shift left - now it's 4,2,1 for <, =, > + andb RELFLG ; keep only the truth we care about + beq LB348 ; brif no matching bits - it's false + ldb #0xff ; set true +LB348 jmp LBC7C ; convert result to FP and return it +; DIM command +LB34B jsr LB26D ; make sure there's a comma between variables +DIM ldb #1 ; flag that we're dimensioning + bsr LB35A ; go allocate the variable + jsr GETCCH ; are we done? + bne LB34B ; brif not + rts +; This routine parses a variable. For scalars, it will return a NULL string or 0 value number +; if it is called from "evaluate term". Otherwise, it allocates the variable. For arrays, it will +; allocate a default sized array if dimensioning is not underway and then attempt to look up +; the requested coordinates in that array. Otherwise, it will allocate an array based on the +; specified dimension values. +LB357 clrb ; flag that we're not setting up an array + jsr GETCCH +LB35A stb DIMFLG ; save dimensioning flag + sta VARNAM ; save first character of variable name + jsr GETCCH ; get input character (why? we already have it) + bsr LB3A2 ; set carry if not alpha + lbcs LB277 ; brif our variable doesn't start with a letter + clrb ; default second variable character to NUL + stb VALTYP ; set value type to numeric + jsr GETNCH ; get second character + bcs LB371 ; brif numeric - numbers are allowed + bsr LB3A2 ; set carry if not alpha + bcs LB37B ; brif not alpha +LB371 tfr a,b ; save set second character of variable name +LB373 jsr GETNCH ; get an input character + bcs LB373 ; brif numeric - still in variable name + bsr LB3A2 ; set carry if not alpha + bcc LB373 ; brif alpha - still in variable name +LB37B cmpa #'$ ; do we have the string sigil? + bne LB385 ; brif not + com VALTYP ; set value type to string + addb #0x80 ; set bit 7 of second variable character to indicate string + jsr GETNCH ; eat the sigil +LB385 stb VARNAM+1 ; save second variable name character + ora ARYDIS ; merge array disable flag (will set bit 7 of input character if no arrays) + suba #'( ; do we have a subscript? + lbeq LB404 ; brif so + clr ARYDIS ; disable the array disable flag - it's single use + ldx VARTAB ; point to the start of the variable table + ldd VARNAM ; get variable name +LB395 cmpx ARYTAB ; are we at the top of the variable table? + beq LB3AB ; brif so + cmpd ,x++ ; does the variable name match (and move pointer to variable data) + beq LB3DC ; brif so + leax 5,x ; move to next table entry + bra LB395 ; see if we have a match +; Set carry if not upper case alpha +LB3A2 cmpa #'A ; set C if less than A + bcs LB3AA ; brif less than A + suba #'Z+1 ; set C if greater than Z + suba #-('Z+1) +LB3AA rts +LB3AB ldx #ZERO ; point to empty location (NULL/0 value) + ldu ,s ; get caller address + cmpu #LB287 ; coming from "evaluate term"? + beq LB3DE ; brif so - don't allocate + ldd ARYEND ; get end of arrays + std V43 ; save as top of source block + addd #7 ; 7 bytes per scalar entry + std V41 ; save as top of destination block + ldx ARYTAB ; get bottom of arrays + stx V47 ; save as bottom of source block + jsr LAC1E ; move the arrays up to make a hole + ldx V41 ; get new top of arrays + stx ARYEND ; set new end of arrays + ldx V45 ; get bottom of destination block + stx ARYTAB ; set as new start of arrays + ldx V47 ; get old end of variables + ldd VARNAM ; get name of variable + std ,x++ ; set variable name and advance X to the value + clra ; zero out the variable value + clrb + std ,x + std 2,x + sta 4,x +LB3DC stx VARPTR ; save descriptor address of return value +LB3DE rts +; Various integer conversion routines +LB3DF fcb 0x90,0x80,0x00,0x00,0x00 ; FP constant -32768 +LB3E4 jsr GETNCH ; fetch input character +LB3E6 jsr LB141 ; evaluate numeric expression +LB3E9 lda FP0SGN ; get sign of value + bmi LB44A ; brif negative (raise FC error) +INTCNV jsr LB143 ; TM error if string + lda FP0EXP ; get exponent + cmpa #0x90 ; is it within the range for a 16 bit integer? + blo LB3FE ; brif smaller than 32768 + ldx #LB3DF ; point to -32678 constant + jsr LBC96 ; is FPA0 equal to -32768? + bne LB44A ; brif not - magnitude is too far negative +LB3FE jsr LBCC8 ; move binary point to the right of FPA0 and correct sign + ldd FPA0+2 ; get the resulting integer + rts +LB404 ldd DIMFLG ; get dimensioning flag and variable type + pshs b,a ; save them (to avoid issues while evaluating dimension values) + nop ; dead space caused by 1.2 revision + clrb ; reset dimension counter +LB40A ldx VARNAM ; get variable name + pshs x,b ; save dimension counter and variable name + bsr LB3E4 ; evaluate a dimension value (and skip either ( or ,) + puls b,x,y ; get variable name, dimension counter, and dimensioning/type flag + stx VARNAM ; restore variable name + ldu FPA0+2 ; get dimension size/index + pshs u,y ; save dimension size and dimensioning/type flag + incb ; bump dimension counter + jsr GETCCH ; get what's after the dimension count + cmpa #', ; do we have another dimension? + beq LB40A ; brif so - parse it + stb TMPLOC ; save dimension counter + jsr LB267 ; make sure we have a ) + puls a,b ; get back variable type and dimensioning flag + std DIMFLG ; restore variable type and dimensioning flag + ldx ARYTAB ; get start of arrays +LB42A cmpx ARYEND ; are we at the end of the array table + beq LB44F ; brif so + ldd VARNAM ; get variable name + cmpd ,x ; does it match? + beq LB43B ; brif so + ldd 2,x ; get length of this array + leax d,x ; move to next array + bra LB42A ; go check another entry +LB43B ldb #2*9 ; code for redimensioned array error + lda DIMFLG ; are we dimensioning? + bne LB44C ; brif so - raise error + ldb TMPLOC ; get number of dimensions given + cmpb 4,x ; does it match? + beq LB4A0 ; brif so +LB447 ldb #8*2 ; raise "bad subscript" + skip2 +LB44A ldb #4*2 ; raise "illegal function call" +LB44C jmp LAC46 ; raise error +LB44F ldd #5 ; 5 bytes per array entry + std COEFPT ; initialize array size to entry size + ldd VARNAM ; get variable name + std ,x ; set array name + ldb TMPLOC ; get dimension count + stb 4,x ; set dimension count + jsr LAC33 ; make sure we haven't overflowed memory + stx V41 ; save array descriptor address +LB461 ldb #11 ; default dimension value (zero-based, gives max index of 10) + clra ; zero extend (??? why not LDD above?) + tst DIMFLG ; are we dimensioning? + beq LB46D ; brif not + puls a,b ; get dimension size + addd #1 ; account for zero based indexing +LB46D std 5,x ; save dimension size + bsr LB4CE ; multiply by accumulated array size + std COEFPT ; save new array size + leax 2,x ; move to next dimension + dec TMPLOC ; have we done all dimensions? + bne LB461 ; brif not + stx TEMPTR ; save end of array descriptor (minus 5) + addd TEMPTR ; add total size of array to address of descriptor + lbcs LAC44 ; brif it overflows memory + tfr d,x ; save end of array for later + jsr LAC37 ; does array fit in memory? + subd #STKBUF-5 ; subtract out the "stack fudge factor" but add 5 to the result + std ARYEND ; save new end of arrays + clra ; set up for clearing +LB48C leax -1,x ; move back one + sta 5,x ; blank out a byte in the array data + cmpx TEMPTR ; have we reached the array header? + bne LB48C ; brif not + ldx V41 ; get address of start of descriptor + lda ARYEND ; get MSB of end of array back (B still has LSB) + subd V41 ; subtract start of descriptor + std 2,x ; save length of array in array header + lda DIMFLG ; are we dimensioning? + bne LB4CD ; brif so - we're done +LB4A0 ldb 4,x ; get number of dimensions + stb TMPLOC ; initialize counter + clra ; initialize accumulated offset + clrb +LB4A6 std COEFPT ; save accumulated offset + puls a,b ; get desired index + std FPA0+2 ; save it + cmpd 5,x ; is it in range for this dimension? + bhs LB4EB ; brif not + ldu COEFPT ; get accumulated offset + beq LB4B9 ; brif first dimension + bsr LB4CE ; multiply accumulated offset by dimension length + addd FPA0+2 ; add in offset into this dimension +LB4B9 leax 2,x ; move to next dimension in header + dec TMPLOC ; done all dimensions? + bne LB4A6 ; brif not + std ,--s ; save D for multiply by 5 (should be pshs d) + aslb ; times 2 + rola + aslb ; times 4 + rola + addd ,s++ ; times 5 + leax d,x ; add in offset from start of array data + leax 5,x ; offset to end of header + stx VARPTR ; save pointer to element data +LB4CD rts +; multiply 16 bit number at 5,x by the 16 bit number in COEFPT; return result in D; BS error if carry +LB4CE lda #16 ; 16 shifts to do a multiply + sta V45 ; save shift counter + ldd 5,x ; get multiplier + std BOTSTK ; save it + clra ; zero out product + clrb +LB4D8 aslb ; shift product left + rola + bcs LB4EB ; brif we have a carry + asl COEFPT+1 ; shift other factor left + rol COEFPT + bcc LB4E6 ; brif no carry - this bit position is 0 + addd BOTSTK ; add in multiplier at this bit position + bcs LB4EB ; brif carry - do an error +LB4E6 dec V45 ; have we done all 16 bits? + bne LB4D8 ; brif not + rts +LB4EB jmp LB447 ; raise a BS error +; MEM function +; BUG: this doesn't account for the STKBUF fudge factor used for memory availability checks +MEM tfr s,d ; get stack pointer where we can do math + subd ARYEND ; calculate number of bytes between the stack and the top of arrays + skip1 ; return result +; Convert unsigned value in B to FP +LB4F3 clra ; zero extend +; Convert signed value in D to FP +GIVABF clr VALTYP ; set value type to numeric + std FPA0 ; save value in FPA0 + ldb #0x90 ; exponent for top two bytes to be an integer + jmp LBC82 ; finish conversion to integer +; STR$ function +STR jsr LB143 ; make sure we have a number + ldu #STRBUF+2 ; convert FP number to string in temporary string buffer + jsr LBDDC + leas 2,s ; don't return to the function evaluator (which will do a numeric type check) + ldx #STRBUF+1 ; point to number string + bra LB518 ; to stash the string in string space and return to the "evaluate term" caller +; Reserve B bytes of string space. Return start in X and FRESPC +LB50D stx V4D ; save X somewhere in case the caller needs it +LB50F bsr LB56D ; allocate string space +LB511 stx STRDES+2 ; save pointer to allocated space in the temporary descriptor + stb STRDES ; save length in the temporary descriptor + rts +LB516 leax -1,x ; move pointer back one (to compensate for the increment below) +; Scan from X until either NUL or one of the string terminators is found +LB518 lda #'" ; set terminator to be string delimiter +LB51A sta CHARAC ; set both delimiters + sta ENDCHR +LB51E leax 1,x ; move to next character + stx RESSGN ; save start of string + stx STRDES+2 ; save start of string in the temporary string descriptor + ldb #-1 ; initialize length counter to -1 (compensate for initial INCB) +LB526 incb ; bump string length + lda ,x+ ; get character from string + beq LB537 ; brif end of line + cmpa CHARAC ; is it delimiter #1? + beq LB533 ; brif so + cmpa ENDCHR ; is it delimiter #2? + bne LB526 ; brif not - keep scanning +LB533 cmpa #'" ; string delimiter? + beq LB539 ; brif so - don't move pointer back +LB537 leax -1,x ; move pointer back (so we don't consume the delimiter) +LB539 stx COEFPT ; save end of string address + stb STRDES ; save string length + ldu RESSGN ; get start of string + cmpu #STRBUF+2 ; is it at the start of the string buffer? + bhi LB54C ; brif so - don't copy it to string space + bsr LB50D ; allocate string space + ldx RESSGN ; point to beginning of the string + jsr LB645 ; copy string data (B bytes) from (X) to (FRESPC) +; Put temporary string descriptor on the string stack +LB54C ldx TEMPPT ; get top of string stack + cmpx #CFNBUF ; is the string stack full? + bne LB558 ; brif not + ldb #15*2 ; code for "string formula too complex" +LB555 jmp LAC46 ; raise error +LB558 lda STRDES ; get string length + sta 0,x ; save it in the string stack descriptor + ldd STRDES+2 ; get string data pointer + std 2,x ; save in string stack descriptor + lda #0xff ; set value type to string + sta VALTYP + stx LASTPT ; set pointer to last used entry on the string stack + stx FPA0+2 ; set pointer to descriptor in the current evaluation value + leax 5,x ; advance string stack pointer + stx TEMPPT + rts +; Reserve B bytes in string space. If there isn't enough space, try compacting string space and +; then try the allocation again. If it still fails, raise OS error. +LB56D clr GARBFL ; flag that compaction not yet done +LB56F clra ; zero extend the length + pshs d ; save requested string length + ldd STRTAB ; get current bottom of strings + subd ,s+ ; calculate new bottom of strings and remove zero extension + cmpd FRETOP ; does the string fit? + blo LB585 ; brif not - try compaction + std STRTAB ; save new bottom of strings + ldx STRTAB ; get bottom of strings + leax 1,x ; now X points to the real start of the allocated space + stx FRESPC ; save the string pointer + puls b,pc ; restore length and return +LB585 ldb #2*13 ; code for out of string space + com GARBFL ; have we compacted string space yet? + beq LB555 ; brif so - raise error + bsr LB591 ; compact string space + puls b ; get back string length + bra LB56F ; go try allocation again +; Compact string space +; This is an O(n^2) algorithm. It first searches all extant strings for the highest address data pointer +; that hasn't already been moved into the freshly compacted string space. If then moves that string data +; up to the highest address it can go to. It repeats this process over and over until it finds no string +; that isn't already in the compacted space. While doing this, it has to search all strings on the string +; stack (this is why the string stack is needed - so we can track anonymous strings), all scalar string +; variables, and *every* entry in every string array. +LB591 ldx MEMSIZ ; get to of string space +LB593 stx STRTAB ; save top of uncompacted stringspace + clra ; zero out D and reset pointer to discovered variable to NULL + clrb + std V4B + ldx FRETOP ; point to bottom of string space + stx V47 ; save as lowest match address (match will be higher) + ldx #STRSTK ; point to start of string stack +LB5A0 cmpx TEMPPT ; are we at the top of the string stack? + beq LB5A8 ; brif so - done with the string stack + bsr LB5D8 ; check for string in uncompacted space (and advance pointer) + bra LB5A0 ; check another on the string stack +LB5A8 ldx VARTAB ; point to start of scalar variables +LB5AA cmpx ARYTAB ; end of scalars? + beq LB5B2 ; brif so + bsr LB5D2 ; check for string in uncompacted space and advance pointer + bra LB5AA ; check another variable +LB5B2 stx V41 ; save address of end of variables (address of first array) +LB5B4 ldx V41 ; get start of the next array +LB5B6 cmpx ARYEND ; end of arrays? + beq LB5EF ; brif so + ldd 2,x ; get length of array + addd V41 ; add to start of array + std V41 ; save address of next array + lda 1,x ; get second character of variable name + bpl LB5B4 ; brif numeric + ldb 4,x ; get number of dimensions + aslb ; two bytes per dimension size + addb #5 ; add in fixed overhead for array descriptor + abx ; now X points to first array element +LB5CA cmpx V41 ; at the start of the next array? + beq LB5B6 ; brif so - go handle another array + bsr LB5D8 ; check for string in uncompacted space (and advance pointer) + bra LB5CA ; process next array element +LB5D2 lda 1,x ; get second character of variable name + leax 2,x ; move to variable data + bpl LB5EC ; brif numeric +LB5D8 ldb ,x ; get length of string + beq LB5EC ; brif NULL - don't need to check data pointer + ldd 2,x ; get data pointer + cmpd STRTAB ; is it in compacted string space? + bhi LB5EC ; brif so + cmpd V47 ; is it better match than previous best? + bls LB5EC ; brif not + stx V4B ; save descriptor address of best match + std V47 ; save new best data pointer match +LB5EC leax 5,x ; move to next descriptor +LB5EE rts +LB5EF ldx V4B ; get descriptor address of the matched string + beq LB5EE ; brif we didn't find one - we're done + clra ; zero extend length + ldb ,x ; get string length + decb ; subtract one (we won't have a NULL string here) + addd V47 ; now D points to the address of the end of the string data + std V43 ; save as top address of move + ldx STRTAB ; set top of uncompacted space as destination + stx V41 + jsr LAC20 ; move string to top of uncompactedspace + ldx V4B ; point to string descriptor + ldd V45 ; get new data pointer address + std 2,x ; update descriptor + ldx V45 ; get bottom of copy destination + leax -1,x ; move back below it + jmp LB593 ; go search for another string to move (and set new bottom of string space) +; Concatenate two strings. We come here directly from the operator handler rather than via a JSR. +LB60F ldd FPA0+2 ; get string descriptor for the first string + pshs d ; save it + jsr LB223 ; evaluate a second string (concatenation is left associative) + jsr LB146 ; make sure we have a string + puls x ; get back first string descriptor + stx RESSGN ; save it + ldb ,x ; get length of first string + ldx FPA0+2 ; get pointer to second string + addb ,x ; add length of second string + bcc LB62A ; brif combined length is OK + ldb #2*14 ; raise string too long error + jmp LAC46 +LB62A jsr LB50D ; reserve room for new string + ldx RESSGN ; get descriptor address of the first string + ldb ,x ; get length of first string + bsr LB643 ; copy it to string space + ldx V4D ; get descriptor address of second string + bsr LB659 ; get string details for second string + bsr LB645 ; copy second string into new string space + ldx RESSGN ; get pointer to first string + bsr LB659 ; remove it from the string stack if possible + jsr LB54C ; put new string on the string stack + jmp LB168 ; return to expression evaluator +; Copy B bytes to space pointed to by FRESPC +LB643 ldx 2,x ; get source address from string descriptor +LB645 ldu FRESPC ; get destination address + incb ; compensate for decb + bra LB64E ; do the copy +LB64A lda ,x+ ; copy a byte + sta ,u+ +LB64E decb ; done yet? + bne LB64A ; brif not + stu FRESPC ; save destination pointer + rts +; Fetch details of string in FPA0+2 and remove from the string stack if possible +LB654 jsr LB146 ; make sure we have a string +LB657 ldx FPA0+2 ; get descriptor pointer +LB659 ldb ,x ; get length of string + bsr LB675 ; see if it's at the top of the string stack and remove it if so + bne LB672 ; brif not removed + ldx 5+2,x ; get start address of string just removed + leax -1,x ; move pointer down 1 + cmpx STRTAB ; is it at the bottom of string space? + bne LB66F ; brif not + pshs b ; save length + addd STRTAB ; add length to start of strings (A was cleared previously) + std STRTAB ; save new string space start (deallocated space for this string) + puls b ; get back string length +LB66F leax 1,x ; restore pointer to pointing at the actual string data + rts +LB672 ldx 2,x ; get data pointer for the string + rts +; Remove string pointed to by X from the string stack if it is at the top of the stack; return with +; A clear and Z set if string removed +LB675 cmpx LASTPT ; is it at the top of the string stack? + bne LB680 ; brif not - do nothing + stx TEMPPT ; save new top of stack + leax -5,x ; move the "last" pointer back as well + stx LASTPT + clra ; flag string removed +LB680 rts +; LEN function +LEN bsr LB686 ; get string details +LB683 jmp LB4F3 ; return unsigned length in B +LB686 bsr LB654 ; get string details and remove from string stack + clr VALTYP ; set value type to numeric + tstb ; set flags according to length + rts +; CHR$ function +CHR jsr LB70E ; get 8 bit unsigned integer to B +LB68F ldb #1 ; allocate a one byte string + jsr LB56D + lda FPA0+3 ; get character code + jsr LB511 ; save reserved string details in temp descriptor + sta ,x ; put character in string +LB69B leas 2,s ; don't go back to function handler - avoid numeric type check +LB69D jmp LB54C ; return temporary string on string stack +; ASC function +ASC bsr LB6A4 ; get first character of argument + bra LB683 ; return unsigned code in B +LB6A4 bsr LB686 ; fetch string details + beq LB706 ; brif NULL string + ldb ,x ; get character at start of string + rts +; LEFT$ function +LEFT bsr LB6F5 ; get arguments from the stack +LB6AD clra ; clear pointer offset (set to start of string) +LB6AE cmpb ,x ; are we asking for more characters than there are in the string? + bls LB6B5 ; brif not + ldb ,x ; only return the number that are in the string + clra ; force starting offset to be the start of the string +LB6B5 pshs b,a ; save offset and length + jsr LB50F ; reserve space in string space + ldx V4D ; point to original string descriptor + bsr LB659 ; get string details + puls b ; get string offset + abx ; now X points to the start of the data to copy + puls b ; get length of copy + jsr LB645 ; copy the data to the allocated space + bra LB69D ; return temp string on string stack +; RIGHT$ function +RIGHT bsr LB6F5 ; get arguments from stack + suba ,x ; subtract length of original string from desired length + nega ; now A is offset into old string where we start copying + bra LB6AE ; go handle everything else +; MID$ function +MID ldb #255 ; default length is the whole string + stb FPA0+3 ; save it + jsr GETCCH ; see what we have after offset + cmpa #') ; end of function? + beq LB6DE ; brif so - no length + jsr LB26D ; force a comma + bsr LB70B ; get length parameter +LB6DE bsr LB6F5 ; get string and offset parameters from the stack + beq LB706 ; brif we have a 0 offset requested (string offsets are 1-based) + clrb ; clear length counter + deca ; subtract one from position parameter (we work on 0-based, param is 1-based) + cmpa ,x ; is start greater than length of string? + bhs LB6B5 ; brif so - return NULL string + tfr a,b ; save absolute position parameter + subb ,x ; now B is postition less length + negb ; now B is amount of string to copy + cmpb FPA0+3 ; is it less than the length requested? + bls LB6B5 ; brif so + ldb FPA0+3 ; set length to the requested length + bra LB6B5 ; go finish up copying the substring +; Common routine for LEFT$, RIGHT$, MID$ - check for ) and fetch string data and first parameter +; from the stack. These were evaluated in the function evaluation handler. (It's not clear that doing +; it that way is actually beneficial. However, this is what the ROM designers did, so here we are.) +LB6F5 jsr LB267 ; make sure we have ) + ldu ,s ; get return address - we're going to mess with the stack + ldx 5,s ; get address of string descriptor + stx V4D ; save descriptor adddress + lda 4,s ; get first numeric parameter in both A and B + ldb 4,s + leas 7,s ; clean up stack + tfr u,pc ; return to original caller +LB706 jmp LB44A ; raise FC error +; Evaluate an unsigned 8 bit expression to B +LB709 jsr GETNCH ; move to next character +LB70B jsr LB141 ; evaluate a numeric expression +LB70E jsr LB3E9 ; convert to integer in D + tsta ; are we negative or > 255? + bne LB706 ; brif so - FC error + jmp GETCCH ; fetch current input character and return +; VAL function +VAL jsr LB686 ; get string details + lbeq LBA39 ; brif NULL string - return 0 + ldu CHARAD ; get input pointer so we can replace it later + stx CHARAD ; point interpreter at string data + abx ; calculate end address of the string + lda ,x ; get byte after the end of the string + pshs u,x,a ; save end of string address, input pointer, and character after end of string + clr ,x ; put a NUL after the string (stops the number interpreter) + jsr GETCCH ; get input character at start of string + jsr LBD12 ; evaluate numeric expression in string + puls a,x,u ; get back saved character and pointers + sta ,x ; restore byte after string + stu CHARAD ; restore interpeter's input pointer + rts +; Evaluate unsigned expression to BINVAL, then evaluate an unsigned expression to B +LB734 bsr LB73D ; evaluate expression + stx BINVAL ; save result +LB738 jsr LB26D ; make sure there's a comma + bra LB70B ; evaluate unsigned expression to B +; Evaluate unsigned expression in X +LB73D jsr LB141 ; evaluate numeric expression +LB740 lda FP0SGN ; is it negative? + bmi LB706 ; brif so + lda FP0EXP ; get exponent + cmpa #0x90 ; largest possible exponent for 16 bits + bhi LB706 ; brif too large + jsr LBCC8 ; move binary point to right of FPA0 + ldx FPA0+2 ; get resulting unsigned value + rts +; PEEK function +PEEK bsr LB740 ; get address to X + ldb ,x ; get the value at that address + jmp LB4F3 ; return B as unsigned value +; POKE function +POKE bsr LB734 ; evaluate address and byte value + ldx BINVAL ; get address + stb ,x ; put value there + rts +; LLIST command +LLIST ldb #-2 ; set output device to printer + stb DEVNUM + jsr GETCCH ; reset flags for input character and fall through to LIST +; LIST command +LIST pshs cc ; save zero flag (end of statement) + jsr LAF67 ; parse line number + jsr LAD01 ; find address of that line + stx LSTTXT ; save that address as the start of the list + puls cc ; get back ent of statement flag + beq LB784 ; brif end of line - list whole program + jsr GETCCH ; are we at the end of the line (one number)? + beq LB789 ; brif end of line + cmpa #0xac ; is it "-"? + bne LB783 ; brif not + jsr GETNCH ; eat the "-" + beq LB784 ; brif no second number - list to end of program + jsr LAF67 ; evaluate the second number + beq LB789 ; brif illegal number +LB783 rts +LB784 ldu #0xffff ; this will cause listing to do the entire program + stu BINVAL +LB789 leas 2,s ; don't return to the caller - we'll jump back to the main loop + ldx LSTTXT ; get address of line to list +LB78D jsr LB95C ; do a newline if needed + jsr LA549 ; do a break check + ldd ,x ; get address of next line + bne LB79F ; brif not end of program +LB797 jsr LA42D ; close output file + clr DEVNUM ; reset device to screen + jmp LAC73 ; go back to immediate mode +LB79F stx LSTTXT ; save new line address + ldd 2,x ; get line number of this line + cmpd BINVAL ; is it above the end line? + bhi LB797 ; brif so - return + jsr LBDCC ; display line number + jsr LB9AC ; put a space after it + ldx LSTTXT ; get line address + bsr LB7C2 ; detokenize the line + ldx [LSTTXT] ; get pointer to next line + ldu #LINBUF+1 ; point to start of detokenized line +LB7B9 lda ,u+ ; get byte from detokenized line + beq LB78D ; brif end of line + jsr LB9B1 ; output character + bra LB7B9 ; handle next character +; Detokenize a line from (X) to the line input buffer +LB7C2 jsr RVEC24 ; do the RAM hook dance + leax 4,x ; move past next line pointer and line number + ldy #LINBUF+1 ; point to line input buffer (destination) +LB7CB lda ,x+ ; get character from tokenized line + beq LB820 ; brif end of input + bmi LB7E6 ; brif it's a token + cmpa #': ; colon? + bne LB7E2 ; brif not + ldb ,x ; get what's after the colon + cmpb #0x84 ; ELSE? + beq LB7CB ; brif so - suppress the colon + cmpb #0x83 ; '? + beq LB7CB ; brif so - suppress the colon + skip2 +LB7E0 lda #'! ; placeholder for unknown token +LB7E2 bsr LB814 ; stow output character + bra LB7CB ; go process another input character +LB7E6 ldu #COMVEC-10 ; point to command interptation table + cmpa #0xff ; is it a function? + bne LB7F1 ; brif not + lda ,x+ ; get function token + leau 5,u ; shift to the function half of the interpretation tables +LB7F1 anda #0x7f ; remove token bias +LB7F3 leau 10,u ; move to next command/function table + tst ,u ; is this table active? + beq LB7E0 ; brif not - use place holder + suba ,u ; subtract number of tokens handled by this table entry + bpl LB7F3 ; brif this token isn't handled here + adda ,u ; undo extra subtraction + ldu 1,u ; get reserved word list for this table +LB801 deca ; are we at the right entry? + bmi LB80A ; brif so +LB804 tst ,u+ ; end of entry? + bpl LB804 ; brif not + bra LB801 ; see if we're there yet +LB80A lda ,u ; get character from wordlist + bsr LB814 ; put character in the buffer + tst ,u+ ; end of word? + bpl LB80A ; brif not + bra LB7CB ; go handle another input character +LB814 cmpy #LINBUF+LBUFMX ; is there room? + bhs LB820 ; brif not + anda #0x7f ; lose bit 7 + sta ,y+ ; save character in output + clr ,y ; make sure there's always a NUL terminator +LB820 rts +; Tokenize the line that the input pointer is pointing to; put result in the line input buffer; return +; length in D +LB821 jsr RVEC23 ; do the RAM hook dance + ldx CHARAD ; get input pointer + ldu #LINBUF ; set destination pointer +LB829 clr V43 ; clear alpha string flag + clr V44 ; clear DATA flag +LB82D lda ,x+ ; get input character + beq LB852 ; brif end of input + tst V43 ; are we handling an alphanumeric string? + beq LB844 ; brif not + jsr LB3A2 ; set carry if not alpha + bcc LB852 ; brif alpha + cmpa #'0 ; is it below the digits? + blo LB842 ; brif so + cmpa #'9 ; is it within the digits? + bls LB852 ; brif so +LB842 clr V43 ; flag that we're past the alphanumeric string +LB844 cmpa #0x20 ; space? + beq LB852 ; brif so - keep it + sta V42 ; save scan delimiter + cmpa #'" ; string delimiter? + beq LB886 ; brif so - copy until another " + tst V44 ; doing "DATA"? + beq LB86B ; brif not +LB852 sta ,u+ ; put character in output + beq LB85C ; brif end of input + cmpa #': ; colon? + beq LB829 ; brif so - reset DATA and alpha string flags +LB85A bra LB82D ; go process another input character +LB85C clr ,u+ ; put a double NUL at the end + clr ,u+ + tfr u,d ; calculate length of result (includes double NUL and an extra two bytes) + subd #LINHDR + ldx #LINBUF-1 ; point to one before the output + stx CHARAD ; set input pointer there + rts +LB86B cmpa #'? ; print abbreviation? + bne LB873 ; brif not + lda #0x87 ; token for PRINT + bra LB852 ; go stash it +LB873 cmpa #'' ; REM abbreviation? + bne LB88A ; brif not + ldd #0x3a83 ; colon plus ' token + std ,u++ ; put it in the output +LB87C clr V42 ; set delimiter to NUL +LB87E lda ,x+ ; get input + beq LB852 ; brif end of line + cmpa V42 ; at the delimiter? + beq LB852 ; brif so +LB886 sta ,u+ ; save in output + bra LB87E ; keep scanning for delimiter +LB88A cmpa #'0 ; is it below digits? + blo LB892 ; brif so + cmpa #';+1 ; is it digit, colon, or semicolon? + blo LB852 ; brif so +LB892 leax -1,x ; move input pointer back one (to point at this input character) + pshs u,x ; save input and output pointers + clr V41 ; set token type to 0 (command) + ldu #COMVEC-10 ; point to command interpretation table +LB89B clr V42 ; set token counter to 0 (0x80) +LB89D leau 10,u ; + lda ,u ; get number of reserved words + beq LB8D4 ; brif this table isn't active + ldy 1,u ; point to reserved words list +LB8A6 ldx ,s ; get input pointer +LB8A8 ldb ,y+ ; get character from reserved word table + subb ,x+ ; compare with input character + beq LB8A8 ; brif exact match + cmpb #0x80 ; brif it was the last character in word and exact match + bne LB8EA ; brif not + leas 2,s ; remove original input pointer from stack + puls u ; get back output pointer + orb V42 ; create token value (B has 0x80 from above) + lda V41 ; get token type + bne LB8C2 ; brif function + cmpb #0x84 ; is it ELSE? + bne LB8C6 ; brif not + lda #': ; silently add a colon before ELSE +LB8C2 std ,u++ ; put two byte token into output + bra LB85A ; go handle more input +LB8C6 stb ,u+ ; save single byte token + cmpb #0x86 ; DATA? + bne LB8CE ; brif not + inc V44 ; set DATA flag +LB8CE cmpb #0x82 ; REM? + beq LB87C ; brif so - skip over rest of line +LB8D2 bra LB85A ; go handle more input +LB8D4 ldu #COMVEC-5 ; point to interpretation table, function style +LB8D7 com V41 ; invert token flag + bne LB89B ; brif we haven't already done functions + puls x,u ; restore input and output pointers + lda ,x+ ; copy first character + sta ,u+ + jsr LB3A2 ; set C if not alpha + bcs LB8D2 ; brif not alpha - it isn't a variable + com V43 ; set alphanumeric string flag + bra LB8D2 ; process more input +LB8EA inc V42 ; bump token number + deca ; checked all in this table? + beq LB89D ; brif so + leay -1,y ; unconsume last compared character +LB8F1 ldb ,y+ ; end of entry? + bpl LB8F1 ; brif not + bra LB8A6 ; check next reserved word +; PRINT command +PRINT beq LB958 ; brif no argument - do a newline + bsr LB8FE ; process print options + clr DEVNUM ; reset output to screen + rts +LB8FE cmpa #'@ ; is it PRINT @? + bne LB907 ; brif not + jsr LA554 ; move cursor to correct location + bra LB911 ; handle some more +LB907 cmpa #'# ; device number specified? + bne LB918 ; brif not + jsr LA5A5 ; parse device number + jsr LA406 ; check for valid output file +LB911 jsr GETCCH ; get input character + beq LB958 ; brif nothing - do newline + jsr LB26D ; need comma after @ or # +LB918 jsr RVEC9 ; do the RAM hook boogaloo +LB91B beq LB965 ; brif end of input +LB91D cmpa #0xa4 ; TAB(? + beq LB97E ; brif so + cmpa #', ; comma (next tab field)? + beq LB966 ; brif so + cmpa #'; ; semicolon (do not advance print position) + beq LB997 ; brif so + jsr LB156 ; evaluate expression + lda VALTYP ; get type of value + pshs a ; save it + bne LB938 ; brif string + jsr LBDD9 ; convert FP number to string + jsr LB516 ; parse a string and put on string stack +LB938 bsr LB99F ; print string + puls b ; get back variable type + jsr LA35F ; set up print parameters + tst PRTDEV ; is it a display device? + beq LB949 ; brif so + bsr LB958 ; do a newline + jsr GETCCH ; get input + bra LB91B ; process more print stuff +LB949 tstb ; set flags on print position + bne LB954 ; brif not at start of line + jsr GETCCH ; get current input + cmpa #', ; comma? + beq LB966 ; skip to next tab field if so + bsr LB9AC ; send a space +LB954 jsr GETCCH ; get input character + bne LB91D ; brif not end of statement +LB958 lda #0x0d ; carriage return + bra LB9B1 ; send it to output +LB95C jsr LA35F ; set up print parameters +LB95F beq LB958 ; brif width is 0 + lda DEVPOS ; get line position + bne LB958 ; brif not at start of line +LB965 rts +LB966 jsr LA35F ; set up print parameters + beq LB975 ; brif line width is 0 + ldb DEVPOS ; get line position + cmpb DEVLCF ; at or past last comma field? + blo LB977 ; brif so + bsr LB958 ; move to next line + bra LB997 ; handle more stuff +LB975 ldb DEVPOS ; get line position +LB977 subb DEVCFW ; subtract a comma field width + bhs LB977 ; brif we don't have a remainder yet + negb ; now B is number of of spaces needed + bra LB98E ; go advance +LB97E jsr LB709 ; evaluate TAB distance + cmpa #') ; closing )? + lbne LB277 ; brif not + jsr LA35F ; set up print parameters + subb DEVPOS ; subtract print position from desired position + bls LB997 ; brif we're already past it +LB98E tst PRTDEV ; is it a display device? + bne LB997 ; brif not +LB992 bsr LB9AC ; output a space + decb ; done enough? + bne LB992 ; brif not +LB997 jsr GETNCH ; get input character + jmp LB91B ; process more items +; cpoy string from (X-1) to output +LB99C jsr LB518 ; parse the string +LB99F jsr LB657 ; get string details +LB9A2 incb ; compensate for decb +LB9A3 decb ; done all of the string? + beq LB965 ; brif so + lda ,x+ ; get character from string + bsr LB9B1 ; send to output + bra LB9A3 ; go do another character +LB9AC lda #0x20 ; space character + skip2 +LB9AF lda #'? ; question mark character +LB9B1 jmp PUTCHR ; output character +; The floating point math package and related functions and operations follow from here +; to the end of the Color Basic ROM area +LB9B4 ldx #LBEC0 ; point to FP constant 0.5 + bra LB9C2 ; add 0.5 to FPA0 +LB9B9 jsr LBB2F ; unpack FP data from (X) to FPA1 +; subtraction operator +LB9BC com FP0SGN ; invert sign of FPA0 (subtracting is adding the negative) + com RESSGN ; that also inverts the sign differential + bra LB9C5 ; go add the negative of FPA0 to FPA1 +LB9C2 jsr LBB2F ; unpack FP data from (X) to FPA1 +; addition operator +LB9C5 tstb ; check exponent of FPA0 + lbeq LBC4A ; copy FPA1 to FPA0 if FPA0 is 0 + ldx #FP1EXP ; point X to FPA1 (first operand) as the operand to denormalize +LB9CD tfr a,b ; put exponent of FPA1 into B + tstb ; is FPA1 0? + beq LBA3E ; brif exponent is 0 - no-op; adding 0 to FPA0 + subb FP0EXP ; get difference in exponents - number of bits to shift the smaller mantissa + beq LBA3F ; brif exponents are equal - no need to denormalize + blo LB9E2 ; brif FPA0 > FPA1 + sta FP0EXP ; replace result exponent with FPA1's (FPA1 is bigger) + lda FP1SGN ; also copy sign over + sta FP0SGN + ldx #FP0EXP ; point to FPA0 (we need to denormalize the smaller number) + negb ; invert the difference - this is the number of bits to shift the mantissa +LB9E2 cmpb #-8 ; do we have to shift by a whole byte? + ble LBA3F ; brif so start by shifting whole bytes to the right + clra ; clear overflow byte + lsr 1,x ; shift high bit of mantissa right (LSR will force a zero into the high bit) + jsr LBABA ; shift remainder of mantissa right -B times +LB9EC ldb RESSGN ; get the sign flag + bpl LB9FB ; brif signs are the same (we add the mantissas then) + com 1,x ; complement the mantissa and extra precision bytes + com 2,x + com 3,x + com 4,x + coma + adca #0 ; add one to A (COM sets C); this may cause a carry to enter the ADD below +LB9FB sta FPSBYT ; save extra precision byte + lda FPA0+3 ; add the main mantissa bytes (and propage carry from above) + adca FPA1+3 + sta FPA0+3 + lda FPA0+2 + adca FPA1+2 + sta FPA0+2 + lda FPA0+1 + adca FPA1+1 + sta FPA0+1 + lda FPA0 + adca FPA1 + sta FPA0 + tstb ; were signs the same? + bpl LBA5C ; brif so - number may have gotten bigger so normalize if needed +LBA18 bcs LBA1C ; brif we had a carry - result is positive?) + bsr LBA79 ; do a proper negation of FPA0 mantissa +LBA1C clrb ; clear temporary exponent accumulator +LBA1D lda FPA0 ; test high byte of mantissa + bne LBA4F ; brif not 0 - we need to do bit shifting + lda FPA0+1 ; shift left 8 bits + sta FPA0 + lda FPA0+2 + sta FPA0+1 + lda FPA0+3 + sta FPA0+2 + lda FPSBYT + sta FPA0+3 + clr FPSBYT + addb #8 ; account for 8 bits shifted + cmpb #5*8 ; shifted 5 bytes worth? + blt LBA1D ; brif not +LBA39 clra ; zero out exponent and sign - result is 0 +LBA3A sta FP0EXP ; set exponent and sign + sta FP0SGN +LBA3E rts +LBA3F bsr LBAAE ; shift FPA0 mantissa to the right + clrb ; clear carry + bra LB9EC ; get on with adding +LBA44 incb ; account for one bit shift + asl FPSBYT ; shift mantissa and extra precision left + rol FPA0+3 + rol FPA0+2 + rol FPA0+1 + rol FPA0 +LBA4F bpl LBA44 ; brif we haven't got a 1 in bit 7 + lda FP0EXP ; get exponent of result + pshs b ; subtract shift count from exponent + suba ,s+ + sta FP0EXP ; save adjusted exponent + bls LBA39 ; brif we underflowed - set result to 0 + skip2 +LBA5C bcs LBA66 ; brif mantissa overflowed + asl FPSBYT ; get bit 7 of expra precision to C (used for round off) + lda #0 ; set to 0 without affecting C + sta FPSBYT ; clear out extra precision bits + bra LBA72 ; go round off result +LBA66 inc FP0EXP ; bump exponent (for a right shift to bring carry in) + beq LBA92 ; brif we overflowed + ror FPA0 ; shift carry into mantissa, shift right + ror FPA0+1 + ror FPA0+2 + ror FPA0+3 +LBA72 bcc LBA78 ; brif no round-off needed + bsr LBA83 ; add one to mantissa + beq LBA66 ; brif carry - need to shift right again +LBA78 rts +LBA79 com FP0SGN ; invert sign of value +LBA7B com FPA0 ; first do a one's copmlement + com FPA0+1 + com FPA0+2 + com FPA0+3 +LBA83 ldx FPA0+2 ; add one to mantissa (after one's complement gives two's complement) + leax 1,x ; bump low word + stx FPA0+2 + bne LBA91 ; brif no carry from low word + ldx FPA0 ; bump high word + leax 1,x + stx FPA0 +LBA91 rts +LBA92 ldb #2*5 ; code for overflow + jmp LAC46 ; raise error +LBA97 ldx #FPA2-1 ; point to FPA2 +LBA9A lda 4,x ; shift mantissa right by 8 bits + sta FPSBYT + lda 3,x + sta 4,x + lda 2,x + sta 3,x + lda 1,x + sta 2,x + lda FPCARY ; and handle extra precision on the left + sta 1,x +LBAAE addb #8 ; account for 8 bits shifted + ble LBA9A ; brif more shifts needed + lda FPSBYT ; get sub byte (extra precision) + subb #8 ; undo the 8 added above + beq LBAC4 ; brif difference is 0 +LBAB8 asr 1,x ; shift mantissa and sub byte one bit (keep mantissa high bit set) +LBABA ror 2,x + ror 3,x + ror 4,x + rora + incb ; account for one shift + bne LBAB8 ; brif not enought shifts yet +LBAC4 rts +LBAC5 fcb 0x81,0x00,0x00,0x00,0x00 ; packed FP 1.0 +LBACA bsr LBB2F ; unpack FP value from (X) to FPA1 +; multiplication operator +LBACC beq LBB2E ; brif exponent of FPA0 is 0 (result is 0) + bsr LBB48 ; calculate exponent of product +LBAD0 lda #0 ; zero out mantissa of FPA2 + sta FPA2 + sta FPA2+1 + sta FPA2+2 + sta FPA2+3 + ldb FPA0+3 ; multiply FPA1 by LSB of FPA0 + bsr LBB00 + ldb FPSBYT ; save extra precision byte + stb VAE + ldb FPA0+2 + bsr LBB00 ; again for next byte of FPA0 + ldb FPSBYT + stb VAD + ldb FPA0+1 ; again for next byte of FPA0 + bsr LBB00 + ldb FPSBYT + stb VAC + ldb FPA0 ; and finally for the high byte + bsr LBB02 + ldb FPSBYT + stb VAB + jsr LBC0B ; copy mantissa from FPA2 to FPA0 (result) + jmp LBA1C ; normalize +LBB00 beq LBA97 ; brif multiplier is 0 - just shift, don't multiply +LBB02 coma ; set carry +LBB03 lda FPA2 ; get FPA2 MS byte + rorb ; data bit to carry; will be 0 when all shifts done + beq LBB2E ; brif 8 shifts done + bcc LBB20 ; brif data bit is 0 - no addition + lda FPA2+3 ; add mantissa of FPA1 and FPA2 + adda FPA1+3 + sta FPA2+3 + lda FPA2+2 + adca FPA1+2 + sta FPA2+2 + lda FPA2+1 + adca FPA1+1 + sta FPA2+1 + lda FPA2 + adca FPA1 +LBB20 rora ; shift carry into FPA2 + sta FPA2 + ror FPA2+1 + ror FPA2+2 + ror FPA2+3 + ror FPSBYT + clra ; clear carry + bra LBB03 +LBB2E rts +; Unpack FP value from (X) to FPA1 +LBB2F ldd 1,x ; copy mantissa (and sign) + sta FP1SGN ; save sign bit + ora #0x80 ; make sure mantissa has bit 7 set + std FPA1 + ldb FP1SGN ; get sign + eorb FP0SGN ; set if FPA0 sign differs + stb RESSGN + ldd 3,x ; copy remainder of mantissa + std FPA1+2 + lda ,x ; and exponent + sta FP1EXP + ldb FP0EXP ; fetch FPA0 exponent and set flags + rts +; Calculate eponent for product of FPA0 and FPA1 +LBB48 tsta ; is FPA1 zero? + beq LBB61 ; brif so + adda FP0EXP ; add to exponent of FPA0 (this is how scientific notation works) + rora ; set V if we *don't* have an overflow + rola + bvc LBB61 ; brif exponent too larger or small + adda #0x80 ; restore the bias + sta FP0EXP ; set result exponent + beq LBB63 ; brif 0 - clear FPA0 + lda RESSGN ; the result sign (negative if signs differ) is the result sign + sta FP0SGN ; so set it as such + rts +LBB5C lda FP0SGN ; get sign of FPA0 + coma ; invert sign + bra LBB63 ; zero sign and exponent +LBB61 leas 2,s ; don't go back to caller (mul/div) - return to previous caller +LBB63 lbpl LBA39 ; brif we underflowed - go zero things out +LBB67 jmp LBA92 ; raise overflow error +; fast multiply by 10 - leave result in FPA0 +LBB6A jsr LBC5F ; copy FPA0 to FPA1 (for addition later) + beq LBB7C ; brif exponent is 0 - it's a no-op then + adda #2 ; this gives "times 4" + bcs LBB67 ; raise overflow if required + clr RESSGN ; set result sign to "signs the same" + jsr LB9CD ; add FPA1 to FPA0 "times 5" + inc FP0EXP ; times 10 + beq LBB67 ; brif overflow +LBB7C rts +LBB7D fcb 0x84,0x20,0x00,0x00,0x00 ; packed FP constant 10.0 +; Divide by 10 +LBB82 jsr LBC5F ; move FPA0 to FPA1 + ldx #LBB7D ; point to constant 10 + clrb ; zero sign +LBB89 stb RESSGN ; result will be positive or zero + jsr LBC14 ; unpack constant 10 to FPA0 + skip2 ; fall through to division (divide FPA1 by 10) +LBB8F bsr LBB2F ; unpack FP number from (X) to FPA1 +; division operator +LBB91 beq LBC06 ; brif FPA0 is 0 - division by zero + neg FP0EXP ; get exponent of reciprocal of the divisor + bsr LBB48 ; calculate exponent of quotient + inc FP0EXP ; bump exponent (due to division algorithm below) + beq LBB67 ; brif overflow + ldx #FPA2 ; point to temporary storage location + ldb #4 ; do 5 bytes + stb TMPLOC ; save counter + ldb #1 ; shift counter and quotient byte +LBBA4 lda FPA0 ; compare mantissa of FPA0 to FPA1, set C if FPA1 less + cmpa FPA1 + bne LBBBD + lda FPA0+1 + cmpa FPA1+1 + bne LBBBD + lda FPA0+2 + cmpa FPA1+2 + bne LBBBD + lda FPA0+3 + cmpa FPA1+3 + bne LBBBD + coma ; set C if FPA0 = FPA1 (it "goes") +LBBBD tfr cc,a ; save "it goes" status + rolb ; rotate carry into quotient + bcc LBBCC ; brif carry clear - haven't done 8 shifts yet + stb ,x+ ; save quotient byte + dec TMPLOC ; done enough bytes? + bmi LBBFC ; brif done all 5 + beq LBBF8 ; brif last byte + ldb #1 ; reset shift counter and quotient byte +LBBCC tfr a,cc ; get back carry status + bcs LBBDE ; brif it "went" +LBBD0 asl FPA1+3 ; shift mantissa (dividend) left + rol FPA1+2 + rol FPA1+1 + rol FPA1 + bcs LBBBD ; brif carry - it "goes" so we have to bump quotient + bmi LBBA4 ; brif high order bit is set - compare mantissas + bra LBBBD ; otherwise, count a 0 bit and try next bit +LBBDE lda FPA1+3 ; subtract mantissa of FPA0 from mantissa of FPA1 + suba FPA0+3 + sta FPA1+3 + lda FPA1+2 + sbca FPA0+2 + sta FPA1+2 + lda FPA1+1 + sbca FPA0+1 + sta FPA1+1 + lda FPA1 + sbca FPA0 + sta FPA1 + bra LBBD0 ; go check for another go +LBBF8 ldb #0x40 ; only two bits in last byte (for rounding) + bra LBBCC ; go do the last byte +LBBFC rorb ; get low bits to bits 7,6 and C to bit 5 + rorb + rorb + stb FPSBYT ; save result extra precision + bsr LBC0B ; move FPA2 mantissa to FPA0 (result) + jmp LBA1C ; go normalize the result +LBC06 ldb #2*10 ; division by zero + jmp LAC46 ; raise error +; Copy mantissa of FPA2 to FPA0 +LBC0B ldx FPA2 ; copy high word + stx FPA0 + ldx FPA2+2 ; copy low word + stx FPA0+2 + rts +; unpack FP number at (X) to FPA0 +LBC14 pshs a ; save register + ldd 1,x ; get mantissa high word and sign + sta FP0SGN ; set sign + ora #0x80 ; make sure mantissa always has bit 7 set + std FPA0 + clr FPSBYT ; clear extra precision + ldb ,x ; get exponent + ldx 3,x ; copy mantissa low word + stx FPA0+2 + stb FP0EXP ; save exponent (and set flags) + puls a,pc ; restore register and return +LBC2A ldx #V45 ; point to FPA4 + bra LBC35 ; pack FPA0 there +LBC2F ldx #V40 ; point to FPA3 + skip2 ; fall through to pack FPA0 there +LBC33 ldx VARDES ; get variable descriptor pointer +; Pack FPA0 to (X) +LBC35 lda FP0EXP ; get exponent + sta ,x ; save it + lda FP0SGN ; get sign + ora #0x7f ; force set low bits - only keep sign in high bit + anda FPA0 ; merge in bits 6-0 of high byte of mantissa + sta 1,x ; save it + lda FPA0+1 ; copy next highest byte + sta 2,x + ldu FPA0+2 ; and the low word of the mantissa + stu 3,x + rts +; Copy FPA1 to FPA0; return with sign in A +LBC4A lda FP1SGN ; copy sign +LBC4C sta FP0SGN + ldx FP1EXP ; copy exponent, mantissa high byte + stx FP0EXP + clr FPSBYT ; clear extra precision + lda FPA1+1 ; copy mantissa second highest byte + sta FPA0+1 + lda FP0SGN ; set sign for return + ldx FPA1+2 ; copy low word of mantissa + stx FPA0+2 + rts +; Copy FPA0 to FPA1 +LBC5F ldd FP0EXP ; copy exponent and high byte of mantissa + std FP1EXP + ldx FPA0+1 ; copy middle bytes of mantissa + stx FPA1+1 + ldx FPA0+3 ; copy low byte of mantissa and sign + stx FPA1+3 + tsta ; set flags on exponent + rts +; check FPA0: return B = 0, if FPA0 is 0, 0xff if negative, and 0x01 if positive +LBC6D ldb FP0EXP ; get exponent + beq LBC79 ; brif 0 +LBC71 ldb FP0SGN ; get sign +LBC73 rolb ; get sign to C + ldb #0xff ; set for negative result + bcs LBC79 ; brif negative + negb ; set to 1 for positive +LBC79 rts +; SGN function +SGN bsr LBC6D ; get sign of FPA0 +LBC7C stb FPA0 ; save result + clr FPA0+1 ; clear next lower 8 bits + ldb #0x88 ; exponent if mantissa is 8 bit integer +LBC82 lda FPA0 ; get high bits of mantissa + suba #0x80 ; set C if mantissa was positive (will cause a negation if it was negative) +LBC86 stb FP0EXP ; set exponent + ldd ZERO ; clear out low word + std FPA0+2 + sta FPSBYT ; clear extra precision + sta FP0SGN ; set sign to positive + jmp LBA18 ; normalize the result +; ABS function +ABS clr FP0SGN ; force FPA0 to be positive (yes, it's that simple) + rts +; Compare packed FP number at (X) to FPA0 +; Return with B = -1, 0, 1 for FPA0 <, =, > (X) and flags set based on that +LBC96 ldb ,x ; get exponent of (X) + beq LBC6D ; brif (X) is 0 + ldb 1,x ; get MS byte of mantissa of (X) + eorb FP0SGN ; set bit 7 if signs of (X) and FPA0 differ + bmi LBC71 ; brif signs differ - no need to compare the magnitude +LBCA0 ldb FP0EXP ; compare exponents and brif different + cmpb ,x + bne LBCC3 + ldb 1,x ; compare mantissa (but we have to pack the FPA0 bits first + orb #0x7f ; keep only sign bit (note: signs are the same) + andb FPA0 ; merge in the mantissa bits from FPA0 + cmpb 1,x ; do the packed versions match? + bne LBCC3 ; brif not + ldb FPA0+1 ; compare second byte of mantissas + cmpb 2,x + bne LBCC3 + ldb FPA0+2 ; compare third byte of mantissas + cmpb 3,x + bne LBCC3 + ldb FPA0+3 ; compare low byte of mantissas, but use subtraction so B = 0 on match + subb 4,x + bne LBCC3 + rts ; return B = 0 if (X) = FPA0 +LBCC3 rorb ; shift carry to bit 7 (C set if FPA0 < (X)) + eorb FP0SGN ; invert the comparision sense if the signs are negative + bra LBC73 ; interpret comparison result +; Shift mantissa of FPA0 until the binary point is immediately to the right of the mantissa and set up the +; result as a two's complement value. +LBCC8 ldb FP0EXP ; get exponent of FPA0 + beq LBD09 ; brif FPA0 is zero - we don't have to do anything, just blank it + subb #0xa0 ; calculate number of shifts to get to the correct exponent (binary point to the right) + lda FP0SGN ; do we have a positive number? + bpl LBCD7 ; brif so + com FPCARY ; negate the mantissa and set extra inbound precision to the correct sign + jsr LBA7B +LBCD7 ldx #FP0EXP ; point to FPA0 + cmpb #-8 ; moving by whole bytes? + bgt LBCE4 ; brif not + jsr LBAAE ; do bit shifting + clr FPCARY ; clear carry in byte + rts +LBCE4 clr FPCARY ; clear the extra carry in precision + lda FP0SGN ; get sign of value + rola ; get sign to carry (so rotate repeats the sign) + ror FPA0 ; shift the first bit + jmp LBABA ; do the shifting dance +; INT function +INT ldb FP0EXP ; get exponent + cmpb #0xa0 ; is the number big enough that there can be no fractional part? + bhs LBD11 ; brif so - we don't have to do anything + bsr LBCC8 ; go shift binary point to the right of the mantissa + stb FPSBYT ; save extra precision bits + lda FP0SGN ; get original sign + stb FP0SGN ; force result to be positive + suba #0x80 ; set C if we had a positive result + lda #0xa0 ; set exponent to match denormalized result + sta FP0EXP + lda FPA0+3 ; save low byte + sta CHARAC + jmp LBA18 ; go normalize (this will correct for the two's complement representation of negatives) +LBD09 stb FPA0 ; replace mantissa of FPA0 with contents of B + stb FPA0+1 + stb FPA0+2 + stb FPA0+3 +LBD11 rts +; Convert ASCII string to FP +; BUG: no overflow is checked on the decimal exponent in exponential notation. +LBD12 ldx ZERO ; zero out FPA0 and temporaries + stx FP0SGN + stx FP0EXP + stx FPA0+1 + stx FPA0+2 + stx V47 + stx V45 + bcs LBD86 ; brif input character is numeric + jsr RVEC19 ; do the RAM hook dance + cmpa #'- ; regular negative sign + bne LBD2D ; brif not + com COEFCT ; invert sign + bra LBD31 ; process stuff after the sign +LBD2D cmpa #'+ ; regular plus? + bne LBD35 ; brif not +LBD31 jsr GETNCH ; get character after sign + bcs LBD86 ; brif numeric +LBD35 cmpa #'. ; decimal point? + beq LBD61 ; brif so + cmpa #'E ; scientific notation + bne LBD65 ; brif not + jsr GETNCH ; eat the "E" + bcs LBDA5 ; brif numeric + cmpa #0xac ; negative sign (token)? + beq LBD53 ; brif so + cmpa #'- ; regular negative? + beq LBD53 ; brif so + cmpa #0xab ; plus sign (token)? + beq LBD55 ; brif so + cmpa #'+ ; regular plus? + beq LBD55 + bra LBD59 ; brif no sign found +LBD53 com V48 ; set exponent sign to negative +LBD55 jsr GETNCH ; eat the sign + bcs LBDA5 ; brif numeric +LBD59 tst V48 ; is the exponent sign negatvie? + beq LBD65 ; brif not + neg V47 ; negate base 10 exponent + bra LBD65 +LBD61 com V46 ; toggle decimal point flag + bne LBD31 ; brif we haven't seen two decimal points +LBD65 lda V47 ; get base 10 exponent + suba V45 ; subtract number of places to the right + sta V47 ; we now have a complete decimal exponent + beq LBD7F ; brif we have no base 10 shifting required + bpl LBD78 ; brif positive exponent +LBD6F jsr LBB82 ; divide FPA0 by 10 (shift decimal point left) + inc V47 ; bump exponent + bne LBD6F ; brif we haven't reached 0 yet + bra LBD7F ; return result +LBD78 jsr LBB6A ; multiply by 10 + dec V47 ; downshift the exponent + bne LBD78 ; brif not at 0 yet +LBD7F lda COEFCT ; get desired sign + bpl LBD11 ; brif it will be positive - no need to do anything + jmp LBEE9 ; flip the sign of FPA0 +LBD86 ldb V45 ; get the decimal count + subb V46 ; (if decimal seen, will add one; otherwise it does nothing) + stb V45 + pshs a ; save new digit + jsr LBB6A ; multiply partial result by 10 + puls b ; get back digit + subb #'0 ; remove ASCII bias + bsr LBD99 ; add B to FPA0 + bra LBD31 ; go process another digit +LBD99 jsr LBC2F ; save FPA0 to FPA3 + jsr LBC7C ; convert B to FP number + ldx #V40 ; point to FPA3 + jmp LB9C2 ; add FPA3 and FPA0 +LBDA5 ldb V47 ; get exponent value + aslb ; times 2 + aslb ; times 4 + addb V47 ; times 5 + aslb ; times 10 + suba #'0 ; remove ASCII bias + pshs b ; save acculated result + adda ,s+ ; add new digit to accumulated result + sta V47 ; save new accumulated decimal exponent + bra LBD55 ; interpret another exponent character +LBDB6 fcb 0x9b,0x3e,0xbc,0x1f,0xfd ; packed FP: 99999999.9 +LBDBB fcb 0x9e,0x6e,0x6b,0x27,0xfd ; packed FP: 999999999 +LBDC0 fcb 0x9e,0x6e,0x6b,0x28,0x00 ; pakced FP: 1E9 +LBDC5 ldx #LABE8-1 ; point to "IN" message + bsr LBDD6 ; output the string + ldd CURLIN ; get basic line number +LBDCC std FPA0 ; save 16 bit unsigned integer + ldb #0x90 ; exponent for upper 16 bits of FPA0 to be an integer + coma ; set C (force normalization to treat as positive) + jsr LBC86 ; zero bottom half, save exponent, and normalize + bsr LBDD9 ; convert FP number to ASCII string +LBDD6 jmp LB99C ; output string +; Convert FP number to ASCII string +LBDD9 ldu #STRBUF+3 ; point to buffer address that will not cause string to go to string space +LBDDC lda #0x20 ; default sign is a space character + ldb FP0SGN ; get sign of value + bpl LBDE4 ; brif positive + lda #'- ; use negative sign +LBDE4 sta ,u+ ; save sign + stu COEFPT ; save output buffer pointer + sta FP0SGN ; save sign character + lda #'0 ; result is 0 if exponent is 0 + ldb FP0EXP ; get exponent + lbeq LBEB8 ; brif FPA0 is 0 + clra ; base 10 exponent is 0 for > 1 + cmpb #0x80 ; is number > 1? + bhi LBDFF ; brif so + ldx #LBDC0 ; point to 1E+09 + jsr LBACA ; shift decimal to the right by 9 spaces + lda #-9 ; account for shift +LBDFF sta V45 ; save base 10 exponent +LBE01 ldx #LBDBB ; point to 999999999 + jsr LBCA0 ; are we above that? + bgt LBE18 ; brif so +LBE09 ldx #LBDB6 ; point to 99999999.9 + jsr LBCA0 ; are we above that? + bgt LBE1F ; brif in range + jsr LBB6A ; multiply by 10 (we were small) + dec V45 ; account for shift + bra LBE09 ; see if we've come into range +LBE18 jsr LBB82 ; divide by 10 + inc V45 ; account for shift + bra LBE01 ; see if we've come into range +LBE1F jsr LB9B4 ; add 0.5 to FPA0 (rounding) + jsr LBCC8 ; do the integer dance + ldb #1 ; default decimal flag (force immediate decimal) + lda V45 ; get base 10 exponent + adda #10 ; account for "unormalized" number + bmi LBE36 ; brif number < 1.0 + cmpa #11 ; do we have more than 9 places? + bhs LBE36 ; brif so - do scientific notation + deca + tfr a,b + lda #2 ; force no scientific notation +LBE36 deca ; subtract wo without affecting carry + deca + sta V47 ; save exponent - 0 is do not display in scientific notation + stb V45 ; save number of places to left of decimal + bgt LBE4B ; brif >= 1 + ldu COEFPT ; point to string buffer + lda #'. ; put decimal + sta ,u+ + tstb ; is there anything to left of decimal? + beq LBE4B ; brif not + lda #'0 ; store a zero + sta ,u+ +LBE4B ldx #LBEC5 ; point to powers of 10 + ldb #0x80 ; set digit counter to 0x80 +LBE50 lda FPA0+3 ; add mantissa to power of 10 + adda 3,x + sta FPA0+3 + lda FPA0+2 + adca 2,x + sta FPA0+2 + lda FPA0+1 + adca 1,x + sta FPA0+1 + lda FPA0 + adca ,x + sta FPA0 + incb ; add one to digit counter + rorb ; put carry into bit 7 + rolb ; set V if carry and sign differ + bvc LBE50 ; brif positive mantissa or carry is 0 and negative mantissa + bcc LBE72 ; brif negative mantissa + subb #10+1 ; take 9's complement if adding mantissa + negb +LBE72 addb #'0-1 ; add ASCII bias + leax 4,x ; move to next power of 10 + tfr b,a ; save digit + anda #0x7f ; remove add/subtract flag + sta ,u+ ; put in output + dec V45 ; do we need a decimal yet? + bne LBE84 ; brif not + lda #'. ; put decimal + sta ,u+ +LBE84 comb ; toggle bit 7 (add/sub flag) + andb #0x80 ; only keep bit 7 + cmpx #LBEC5+9*4 ; done all places? + bne LBE50 ; brif not +LBE8C lda ,-u ; get last character + cmpa #'0 ; was it 0? + beq LBE8C ; brif so + cmpa #'. ; decimal? + bne LBE98 ; brif not + leau -1,u ; move past decimal if it isn't needed +LBE98 lda #'+ ; plus sign + ldb V47 ; get scientific notation exponent + beq LBEBA ; brif not scientific notation + bpl LBEA3 ; brif positive exponent + lda #'- ; negative sign for base 10 exponent + negb ; switch to positive exponent +LBEA3 sta 2,u ; put sign + lda #'E ; put "E" + sta 1,u + lda #'0-1 ; init to ASCII 0 (compensate for INC) +LBEAB inca ; bump digit + subb #10 ; have we hit the correct one yet? + bcc LBEAB ; brif not + addb #'9+1 ; convert units digit to ASCII + std 3,u ; put exponent in output + clr 5,u ; put trailing NUL + bra LBEBC ; go reset pointer +LBEB8 sta ,u ; store last character +LBEBA clr 1,u ; put NUL at the end +LBEBC ldx #STRBUF+3 ; point to start of string + rts +LBEC0 fcb 0x80,0x00,0x00,0x00,0x00 ; packed FP 0.5 +LBEC5 fqb -100000000 + fqb 10000000 + fqb -1000000 + fqb 100000 + fqb -10000 + fqb 1000 + fqb -100 + fqb 10 + fqb -1 +LBEE9 lda FP0EXP ; get exponent of FPA0 + beq LBEEF ; brif 0 - don't flip sign + com FP0SGN ; flip sign +LBEEF rts +; Expand a polynomial of the form +; AQ+BQ^3+CQ^5+DQ^7..... where Q is FPA0 and X points to a table +LBEF0 stx COEFPT ; save coefficient table pointer + jsr LBC2F ; copy FPA0 to FPA3 + bsr LBEFC ; multiply FPA3 by FPA0 + bsr LBF01 ; expand polynomial + ldx #V40 ; point to FPA3 +LBEFC jmp LBACA ; multiply FPA0 by FPA3 +LBEFF stx COEFPT ; save coefficient table counter +LBF01 jsr LBC2A ; move FPA0 to FPA4 + ldx COEFPT ; get the current coefficient + ldb ,x+ ; get the number of entries + stb COEFCT ; save as counter + stx COEFPT ; save new pointer +LBF0C bsr LBEFC ; multiply (X) and FPA0 + ldx COEFPT ; get this coefficient + leax 5,x ; move to next one + stx COEFPT ; save new pointer + jsr LB9C2 ; add (X) to FPA0 + ldx #V45 ; point X to FPA4 + dec COEFCT ; done all coefficients? + bne LBF0C ; brif more left + rts +; RND function +RND jsr LBC6D ; set flags on FPA0 + bmi LBF45 ; brif negative - set seed + beq LBF3B ; brif 0 - do random between 0 and 1 + bsr LBF38 ; convert to integer + jsr LBC2F ; save range value + bsr LBF3B ; get random number + ldx #V40 ; point to FPA3 + bsr LBEFC ; multply (X) by FPA0 + ldx #LBAC5 ; point to FP 1.0 + jsr LB9C2 ; add 1 to FPA0 +LBF38 jmp INT ; return integer value +LBF3B ldx RVSEED+1 ; move variable random number seed to FPA0 + stx FPA0 + ldx RVSEED+3 + stx FPA0+2 +LBF45 ldx RSEED ; move fixed seed to FPA1 + stx FPA1 + ldx RSEED+2 + stx FPA1+2 + jsr LBAD0 ; multiply them + ldd VAD ; get lowest order product bytes + addd #0x658b ; add a constant + std RVSEED+3 ; save it as new seed + std FPA0+2 ; save in result + ldd VAB ; get high order extra product bytes + adcb #0xb0 ; add upper bytes of constant + adca #5 + std RVSEED+1 ; save as new seed + std FPA0 ; save as result + clr FP0SGN ; set result to positive + lda #0x80 ; set exponent to 0 < FPA0 < 1 + sta FP0EXP + lda FPA2+2 ; get a byte from FPA2 + sta FPSBYT ; save as extra precision + jmp LBA1C ; go normalize FPA0 +RSEED fqb 0x40e64dab ; constant random number generator seed +; SIN function +SIN jsr LBC5F ; copy FPA0 to FPA1 + ldx #LBFBD ; point to 2*pi + ldb FP1SGN ; get sign of FPA1 + jsr LBB89 ; divide FPA0 by 2*pi + jsr LBC5F ; copy FPA0 to FPA1 + bsr LBF38 ; convert FPA0 to an integer + clr RESSGN ; set result to positive + lda FP1EXP ; get exponent of FPA1 + ldb FP0EXP ; get exponent of FPA0 + jsr LB9BC ; subtract FPA0 from FPA1 + ldx #LBFC2 ; point to FP 0.25 + jsr LB9B9 ; subtract FPA0 from 0.25 (pi/2) + lda FP0SGN ; get result sign + pshs a ; save it + bpl LBFA6 ; brif positive + jsr LB9B4 ; add 0.5 (pi) to FPA0 + lda FP0SGN ; get sign of result + bmi LBFA9 ; brif negative + com RELFLG ; if 3pi/2 >= arg >= pi/2 +LBFA6 jsr LBEE9 ; flip sign of FPA0 +LBFA9 ldx #LBFC2 ; point to 0.25 + jsr LB9C2 ; add 0.25 (pi/2) to FPA0 + puls a ; get original sign + tsta ; was it positive + bpl LBFB7 ; brif so + jsr LBEE9 ; flip result sign +LBFB7 ldx #LBFC7 ; point to series coefficients + jmp LBEF0 ; go calculate value +LBFBD fcb 0x83,0x49,0x0f,0xda,0xa2 ; 2*pi +LBFC2 fcb 0x7f,0x00,0x00,0x00,0x00 ; 0.25 +; modified taylor series SIN coefficients +LBFC7 fcb 6-1 ; six coefficients + fcb 0x84,0xe6,0x1a,0x2d,0x1b ; -((2pi)^11)/11! + fcb 0x86,0x28,0x07,0xfb,0xf8 ; ((2pi)^9)/9! + fcb 0x87,0x99,0x68,0x89,0x01 ; -((2pi)^7)/7! + fcb 0x87,0x23,0x35,0xdf,0xe1 ; ((2pi)^5)/5! + fcb 0x86,0xa5,0x5d,0xe7,0x28 ; -(2pi)^3)/3! + fcb 0x83,0x49,0x0f,0xda,0xa2 ; 2*pi +; these 12 bytes are unused + fcb 0xa1,0x54,0x46,0x8f,0x13,0x8f,0x52,0x43 + fcb 0x89,0xcd,0xa6,0x81 +; these are the hardware interrupt vectors (coco1/2 only) + fdb SW3VEC + fdb SW2VEC + fdb FRQVEC + fdb IRQVEC + fdb SWIVEC + fdb NMIVEC + fdb RESVEC