Mercurial > hg > index.cgi
changeset 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 | 704b2c9dc19e |
| files | .hgignore 00README.txt Makefile bas10.s bas11.s bas12.s bas13.s defs.s disk.s exbas10.s exbas11.s secb.s |
| diffstat | 12 files changed, 40310 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/.hgignore Sat Dec 08 19:57:01 2018 -0700 @@ -0,0 +1,4 @@ +syntax: glob +*~ +*.rom +*.list
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/00README.txt Sat Dec 08 19:57:01 2018 -0700 @@ -0,0 +1,82 @@ +The source files here build to byte accurate versions of the following ROMs +that are found in various Color Computers: + +Color Basic 1.0 +Color Basic 1.1 +Color Basic 1.2 +Color Basic 1.3 +Extended Color Basic 1.0 +Extended Color Basic 1.1 +Extended Color Basic 2.0 (Coco3) +Disk Extended Color Basic 1.0 (shows 2.0 on the Coco3) +Disk Extended Color Basic 1.1 (shows 2.1 on the Coco3) + +The source files are based on the contents of the Unravelled series as +published by Spectral Associates as updated by Walter K. Zydhek. As such, +most of the symbols used will line up with those in the Unravelled series. +There are, however, some significant changes. + +* All source has been convered to use a semicolon to introduce comments + instead of relying on the implied end of line comments. + +* Spaces have been used to line up the columns instead of tabs. 16 spaces + are allowed for the label field. 32 spaces are allowed for the instruction + (both opcode and operand, separated by a single space) in most cases, and + the majority of comments will line up starting at column 49. + +* Source code has been largely converted to lower case. This is a personal + preference, but it also feels a bit less "shouty". Labels, however, have + retained their original case. + +* C style hexadecimal constants have been used in most cases. + +* Features specific to LWASM have been used to create fairly clean listing + files for the various ROMs. LWASM is, of course, required to build the + ROMs from this source. + +* The comments have been extensively rewritten. Any typos now extant in said + comments are entirely the fault of the guy writing them. + +* A few cases where numeric addresses were used instead of labels have been + corrected. + +Comment Accuracy +================ + +This is important to point out. While reasonable efforts have been made to +ensure that the comments accurately reflect what the relevant code is doing, +there are certainly errors that have crept in, or been duplicated from the +original disassembly sources. + +In some cases, the code is just convoluted enough that no reasonable +comments can do it justice. This is especially true in relation to the +floating point implementation. + +In other cases, what the code is doing is relatively clear but why it does +it is not. In other cases, truly understanding what the code is doing +requires a much more advanced understanding of mathematics or other fields +than the commenter has. In these cases, inaccurate comments could well be +present but the commenter would have no way of knowing for sure. + +There are also many cases in the original Unravelled comments where the +comments were just plain wrong or had the sense of a flag or other test +completely reversed. These have been corrected where they were detected, but +there is a great deal of code across the combined 96K of ROM code. + +Finally, some care has been taken to avoid comments the merely describe what +the instruction itself does in a manner that could have come right out of a +CPU reference manual. For instance, an instruction like "STX V4D" is better +left with no comment rather than writing "store X in V4D". + + +Future Updates +============== + +Since this code is basically frozen, any future modifications will be for +aesthetic reasons. Most notably, replacing synthetic address based labels +with more sensible ones would be beneficial. So would replacing variable +names with more descriptive names since the assembler in use supports much +longer symbol names. + +That said, any updates into the future must preserve the output as byte +identicial for obvious reasons.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Makefile Sat Dec 08 19:57:01 2018 -0700 @@ -0,0 +1,39 @@ +LWASM=lwasm + +.PHONY: all +all: defs.list bas10.rom bas11.rom bas12.rom bas13.rom exbas10.rom exbas11.rom disk10.rom disk11.rom secb.rom + +bas10.rom bas10.list: bas10.s defs.s + $(LWASM) --raw --list=bas10.list --symbols -o bas10.rom bas10.s + +bas11.rom bas11.list: bas11.s defs.s + $(LWASM) --raw --list=bas11.list --symbols -o bas11.rom bas11.s + +bas12.rom bas12.list: bas12.s defs.s + $(LWASM) --raw --list=bas12.list --symbols -o bas12.rom bas12.s + +bas13.rom bas13.list: bas13.s defs.s + $(LWASM) --raw --list=bas13.list --symbols -o bas13.rom bas13.s + +exbas10.rom exbas10.list: exbas10.s defs.s + $(LWASM) --raw --list=exbas10.list --symbols -o exbas10.rom exbas10.s + +exbas11.rom exbas11.list: exbas11.s defs.s + $(LWASM) --raw --list=exbas11.list --symbols -o exbas11.rom exbas11.s + +disk10.rom disk10.list: disk.s defs.s + $(LWASM) --raw --list=disk10.list --symbols -DDISKVER=0 -o disk10.rom disk.s + +disk11.rom disk11.list: disk.s defs.s + $(LWASM) --raw --list=disk11.list --symbols -DDISKVER=1 -o disk11.rom disk.s + +secb.rom secb.list: secb.s defs.s + $(LWASM) --raw --list=secb.list --symbols -o secb.rom secb.s + +defs.list: defs.s + $(LWASM) --list=defs.list -o defs.bin defs.s + rm -f defs.bin + +.PHONY: clean +clean: + rm -f *.rom *.list *~
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/bas10.s Sat Dec 08 19:57:01 2018 -0700 @@ -0,0 +1,4064 @@ + *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 ldu #LA00E ; point to warm start check code +LA02A clrb ; use page 0 as direct page + tfr b,dp + ldx #PIA0 ; point to PIA0 (keyboard) + clr 1,x ; enable direction register for PIA0 DA + clr 3,x ; enable direction register for PIA0 DB + clr ,x ; set PIA0 DA to input (keyboard rows, comparator) + ldd #0xff34 + sta 2,x ; set PIA0 DB to output (keyboard columns) + stb 1,x ; set PIA0 DA to data mode + stb 3,x ; set PIA0 DB to data mode + ldx #PIA1 ; point to misc PIA + clr 1,x ; enable direction register for PIA1 DA + clr 3,x ; enable direction register for PIA1 DB + deca + sta ,x ; set PIA1 DA as output except for bit 0 (DAC, printer, cassette input) + lda #0xf8 ; set VDG control to output, other bits input (printer handshake, etc.) + sta 2,x + stb 1,x ; enable data mode for PIA1 DA + stb 3,x ; enable data mode for PIA1 DB + clr 2,x ; set VDG to alphanumeric + lda #2 ; set rs232 to marking + sta ,x + lda 2,x ; get RAM jumper setting + ldx #SAMREG ; point to SAM control register + ldb #16 ; 16 bits to clear +LA05E sta ,x++ ; clear a SAM bit + decb ; done all 16? + bne LA05E ; brif not + sta SAMREG+9 ; put display at 0x400 + anda #4 ; keep only RAMSZ input + beq LA06C ; brif 4K RAM + sta -5,x ; set for 16K +LA06C jmp ,u ; go do warm/cold start +BACDST ldx #0 ; point to start of memory +LA071 clr ,x+ ; clear byte + cmpx #VIDRAM ; at display? + bne LA071 ; brif not + jsr LA928 ; clear screen + ldx #LA10D ; point to variabl einitializers + ldu #CMPMID ; point to destination + ldb #28 + jsr LA59A ; copy initializers + ldu #IRQVEC ; point to second destination + ldb #30 + jsr LA59A ; copy initializers + ldx #LB277 ; init extended basic's COMVEC stuff to error + stx 3,u + stx 8,u + ldx #RVEC0 ; point to ram vectors + lda #$39 ; RTS opcode +LA094 sta ,x+ ; init a byte + cmpx #RVEC0+25*3 ; end of vectors? + bne LA094 ; brif not + sta LINHDR-1 ; set "next line address" in line input buffer to nonzero + ldx #VIDRAM+$200 ; point to end of display screen + clr ,x+ ; put a constant zero before start of program + stx TXTTAB ; set start ofprogram +LA0AB lda 2,x ; look for end of memory + coma + sta 2,x + cmpa 2,x + bne LA0BA ; brif it wasn't RAM + leax 1,x ; move pointer forward +LA0B6 com 1,x ; restore memory value + bra LA0AB ; check another byte +LA0BA stx TOPRAM ; set top of memory + stx MEMSIZ ; set top of string space + stx STRTAB ; set bottom of allocated string space + leax -200,x ; allocate 200 bytes for string space + stx FRETOP ; save top of free memory + tfr x,s ; put the stack there too + 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 + ldu #LA108 ; 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 87 ; 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.0' + fcb 0x0d + fcc '(C) 1980 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. This version of the +; routine has a few issues which are finally fixed mostly properly in Color Basic 1.2 +KEYIN pshs x,b ; save registers + bsr LA1C8 ; get keystroke + tsta ; set flags + puls b,x,pc ; restore registers and return +LA1C8 leas -3,s ; make temp storage space + ldx #KEYBUF ; point to keyboard state table + clr 0,s ; reset column counter + ldb #0xfe ; set column strobe to first column + stb PIA0+2 ; set strobe +LA1D4 bsr LA238 ; read keyboard data + sta 1,s ; save keyboard data + eora ,x ; set any bit where a key state changed + anda ,x ; ignore any where a key was released + ldb 1,s ; get new key data + stb ,x+ ; save in state table + tsta ; was a key down? + bne LA1ED ; brif so + inc 0,s ; bump column counter + comb ; set C + rol PIA0+2 ; move column strobe over + bcs LA1D4 ; brif not done all columns + puls b,x,pc ; restore registers and return +LA1ED ldb PIA0+2 ; get strobe data + stb 2,s ; save it + ldb #0xf8 ; make sure B is 0 after first ADDB +LA1F4 addb #8 ; move to next row base + lsra ; at the right row base? + bcc LA1F4 ; brif not + addb 0,s ; add in column offset + beq LA245 ; brif @ + cmpb #26 ; alpha? + bhi LA247 ; brif not + orb #0x40 ; add in uppercase ASCII bias + bsr LA22D ; get shift status + beq LA20E ; brif shift down + lda CASFLG ; check casplock + bne LA20E ; brif not caps mode + orb #0x20 ; convert to lower case +LA20E stb 0,s ; save ASCII value for return later + ldx DEBVAL ; get debounce delay + jsr LA7D3 ; count X down + ldb 2,s ; get column strobe data + stb PIA0+2 ; re-set strobe + bsr LA238 ; read row data + cmpa 1,s ; does it match the result from before the delay? + puls a ; get back key code (return value) + bne LA22A ; brif not the same result + cmpa #0x12 ; is it SHIFT-0? + bne LA22B ; brif not + com CASFLG ; flip capslock state +LA22A clra ; set Z, return 0 for no key down +LA22B puls x,pc ; clean up stack and return +LA22D lda #0x7f ; column strobe for SHIFT + sta PIA0+2 ; strobe keyboard + lda PIA0 ; get row data + anda #0x40 ; keep only shift data + rts +LA238 lda PIA0 ; read row data + ora #0x80 ; mask comparator + tst PIA0+2 ; reading column 7? + bmi LA244 ; brif not + ora #0xc0 ; mask off SHIFT as well +LA244 rts +LA245 ldb #51 ; code for @ +LA247 ldx #CONTAB-0x36 ; point to control code table, first batch + cmpb #33 ; arrows, space, zero? + blo LA264 ; brif not + ldx #CONTAB-0x54 ; point to control code table, second batch + cmpb #48 ; enter, clear, break, @? + bhs LA264 ; brif so + bsr LA22D ; get shift state + cmpb #43 ; number, colon, semicolon? + bls LA25D ; brif so + eora #0x40 ; invert shift state +LA25D tsta ; test shift status + beq LA20E ; brif shift down - we have a result so debounce things + addb #0x10 ; add in ASCII offset correction + bra LA20E ; go debounce things +LA264 aslb ; two bytes per entry + bsr LA22D ; test shift state + bne LA26A ; brif not shift + incb ; select shifted entry +LA26A ldb b,x ; get return value + bra LA20E ; go debounce keyboard +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 +; This routine is changed to send 8 bits of data as of Color Basic 1.1. +; Color Basic 1.2 adds a handshake ; before sending any data. +LA2BF pshs x,b,a,cc ; save registers and interrupt status + orcc #0x50 ; disable interrupts + bsr LA2FB ; set to marking (stop bit) + asla ; send 7 data bits, one start bit + ldb #8 ; 8 bits to send +LA2C8 pshs b ; save bit counter + clrb ; initialize output byte + lsra ; get output bit to C + rolb ; now move it to the right bit in the output + rolb + stb PIA1 ; send bit to printer + bsr LA302 ; do the baud delay (this delay is improved in later versions) + nop + nop + nop + bsr LA302 + puls b ; get bit counter back + decb ; sent all 8 bits? + bne LA2C8 ; brif not + bsr LA2FB ; send stop bit + puls cc,a ; restore output character and interrupt status + cmpa #0x0d ; carriage return? + beq LA2ED ; brif so + inc LPTPOS ; bump output position + ldb LPTPOS ; get new position + cmpb LPTWID ; at end of line? + blo LA2F3 ; brif not +LA2ED clr LPTPOS ; reset output position to start of line + bsr LA305 ; do carriage return delay + bsr LA305 +LA2F3 ldb PIA1+2 ; read rs232 status + lsrb ; get status bit to C + bcs LA2F3 ; brif still not ready + 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 LA449 ; 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 LA6F3 ; 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 KEYIN ; 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 +LB228 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 LB228 ; 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 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 ldb DIMFLG ; get dimensioning flag + lda VALTYP ; get type of variable + pshs b,a ; save them (to avoid issues while evaluating dimension values) + 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 + sta VALTYP ; restore variable type + stb DIMFLG ; restore 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 + bmi 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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/bas11.s Sat Dec 08 19:57:01 2018 -0700 @@ -0,0 +1,4068 @@ + *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 a mask to check RAMSZ input + sta -2,x ; set RAMSZ strobe high + bitb 2,x ; check RAMSZ input + beq LA072 ; brif set for 4K RAMs + clr -2,x ; set strobe low + bitb 2,x ; check input + beq LA070 ; brif set for 64K rams + leau -2,u ; adjust pointer to set SAM for 16K RAMs +LA070 sta -3,u ; program SAM for either 16K or 64K 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 87 ; 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.1' + fcb 0x0d + fcc '(C) 1980 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 +LA1BF puls b,x,pc ; restore registers and return +; This is the actual keyboard polling routine. Returns 0 if no new key is down. Updated compared to 1.0 to reject +; joystick buttons. +KEYIN pshs u,x,b ; save registers + bsr LA1C8 ; get keystroke + tsta ; set flags + puls b,x,u,pc ; restore registers and return +LA1C8 ldu #PIA0 ; point to keyboard PIA + ldx #KEYBUF ; point to state table + clra ; clear carry and set column strobe and counter to 0xff + deca + pshs x,a ; save colomn counter and a couple of holes for temporaries + sta 2,u ; initialize the column strobe to no columns active + skip1 +LA1D5 comb ; set carry flag + rol 2,u ; move to nextcolumn + bcc LA1BF ; brif we've done the last one + inc 0,s ; bump column count + bsr LA239 ; read keyboard row data + sta 1,s ; save key data + eora ,x ; set any bit where a key state changed + anda ,x ; ignore any where a key was released + ldb 1,s ; get new key data + stb ,x+ ; save in state table + tsta ; was a key down? + beq LA1D5 ; brif not - check another + ldb 2,u ; get column strobe data + stb 2,s ; save it for later + ldb #0xf8 ; make sure B is 0 after first ADDB +LA1F1 addb #8 ; adjust to next row + lsra ; are we at the right row base? + bcc LA1F1 ; brif not + addb 0,s ; add in column number + beq LA244 ; brif it was @ + cmpb #26 ; letter? + bhi LA246 ; brif not + orb #0x40 ; add in upper case ASCII bias + bsr LA22E ; check for shift key + beq LA20B ; brif shift down + lda CASFLG ; check casplock + bne LA20B ; brif not caps mode + orb #0x20 ; convert to lower case +LA20B stb 0,s ; temp store ASCII value + ldx DEBVAL ; get debounce dely counter + jsr LA7D3 ; wait while we count X down + ldb #0xff ; set column strobe to no columns + bsr LA237 ; read keyboard data + inca ; do we have anything reading? + bne LA220 ; brif so - reject keyboard read +LA21A ldb 2,s ; get saved column strobe + bsr LA237 ; read the keyboard data + cmpa 1,s ; does it match the result before the delay? +LA220 puls a ; get back return value + bne LA22B ; brif we have a non-match or joystick button + cmpa #0x12 ; SHIFT-0? + bne LA22C ; brif not + com CASFLG ; swap capslock state +LA22B clra ; set Z and return zero for no key down +LA22C puls x,pc ; restore registers and return +LA22E lda #0x7f ; column strobe for SHIFT + sta 2,u ; strobe keyboard + lda ,u ; get row data + anda #0x40 ; only keep shift state + rts +LA237 stb 2,u ; save requested column strobe +LA239 lda ,u ; read row data + ora #0x80 ; mask joystick comparator input + tst 2,u ; are we reading column 7? + bmi LA243 ; brif not + ora #0xc0 ; also mask off the SHIFT key +LA243 rts +LA244 ldb #51 ; scan code for @ +LA246 ldx #CONTAB-0x36 ; point to first batch in control code list + cmpb #33 ; arrows, space, zero? + blo LA263 ; brif so + ldx #CONTAB-0x54 ; point to second batch in control code list + cmpb #48 ; ENTER, CLEAR, BREAK, @? + bhs LA263 ; brif so + bsr LA22E ; get shift status + cmpb #43 ; number, colon, semicolon? + bls LA25C ; brif so + eora #0x40 ; invert shift sense if so +LA25C tsta ; test shift status + beq LA20B ; brif shift down - we have the code so check for debounce + addb #0x10 ; add in ASCII offset + bra LA20B ; check for debounce +LA263 aslb ; two entries for table entry + bsr LA22E ; get shift status + bne LA269 ; brif not down + incb ; move to shifted code entry +LA269 ldb b,x ; get ASCII code + bra LA20B ; go check for debounce + fcb 0 ; unused in Color Basic 1.0 +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 +LA2BF pshs x,b,a,cc ; save registers and interrupt status + orcc #0x50 ; disable interrupts + bsr LA2FB ; set output to marking + clrb ; transmit a start bit + bsr LA2FD + ldb #8 ; send 8 bits +LA2CA pshs b ; save bit counter + clrb ; set output to + lsra ; get output bit to C + rolb ; get it to the correct bit position for output + aslb + bsr LA2FD ; send the bit + puls b ; get back bit counter + decb ; sent all 8 bits? + bne LA2CA ; brif not + bsr LA2FB ; send stop bit (B is 0) + puls cc,a ; restore interrupts and output character + cmpa #0x0d ; carriage return? + beq LA2E7 ; brif so + inc LPTPOS ; bump printer position + ldb LPTPOS ; get current printer position + cmpb LPTWID ; end of line? + blo LA2ED ; brif not +LA2E7 clr LPTPOS ; reset to start of line + bsr LA305 ; delay for carriage return + bsr LA305 +LA2ED ldb PIA1+2 ; get rs232 status + lsrb ; is it "read"? + bcs LA2ED ; brif not + puls b,x,pc ; restore registers and return + fdb 0,0,0 ; unused space +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 KEYIN ; 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 +LB228 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 LB228 ; 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 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 ldb DIMFLG ; get dimensioning flag + lda VALTYP ; get type of variable + pshs b,a ; save them (to avoid issues while evaluating dimension values) + 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 + sta VALTYP ; restore variable type + stb DIMFLG ; restore 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 + bmi 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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/bas12.s Sat Dec 08 19:57:01 2018 -0700 @@ -0,0 +1,4070 @@ + *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 a mask to check RAMSZ input + sta -2,x ; set RAMSZ strobe high + bitb 2,x ; check RAMSZ input + beq LA072 ; brif set for 4K RAMs + clr -2,x ; set strobe low + bitb 2,x ; check input + beq LA070 ; brif set for 64K rams + leau -2,u ; adjust pointer to set SAM for 16K RAMs +LA070 sta -3,u ; program SAM for either 16K or 64K 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.2' + 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
--- /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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/defs.s Sat Dec 08 19:57:01 2018 -0700 @@ -0,0 +1,477 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; First, some useful macro definitions to avoid most instances with FCB standing for actual code. +skip1 macro noexpand + fcb 0x21 ; opcode of BRN which causes next code byte to be skipped + endm +skip2 macro noexpand + fcb 0x8c ; opcode of CMPX immediate which will skip two bytes (but clobbers flags) + endm +skip2keepc macro noexpand + fcb 0x7d ; opcode of TST extended which will skip two bytes like above but preserves C + endm +skip1lda macro noexpand + fcb 0x86 ; opcode of LDA immediate; used to load A with nonzero and skip a CLRA, usually + endm +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Now various constants used in the ROMs. +STKBUF equ 58 ; extra room kept between the stack and variables during memory checks +DEBDEL equ 0x45e ; delay constant for debouncing the keyboard (10ms at standard clock speed) +LBUFMX equ 250 ; size of the line input buffer +MAXLIN equ 0xfa ; the maximum MS byte of a line number +DOSBUF equ 0x2600 ; address where DOS command loads track 24 +DIRLEN equ 32 ; size of a directory entry on disk +SECLEN equ 256 ; length of a disk sector +SECMAX equ 18 ; number of sectors per track +TRKLEN equ SECMAX*SECLEN ; number of bytes on a track +TRKMAX equ 35 ; number of tracks per disk +FATLEN equ 6+(TRKMAX-1)*2 ; size of memory copy of a file allocation table +GRANMX equ (TRKMAX-1)*2 ; number of granules per disk +FCBLEN equ SECLEN+25 ; size of a file control block +INPFIL equ 0x10 ; input file type +OUTFIL equ 0x20 ; output file type +RANFIL equ 0x40 ; random file type +ROWMAX equ 24 ; the number of rows on the hi-res text screen +HRESSCRN equ 0x2000 ; where the hi-res text screen starts in logical memory +HRESBUFF equ 0xc000 ; where the HGET/HPUT buffers are in logical memory +TMPSTACK equ 0xdfff ; temporary stack location when in secondary memory map +CURCHAR equ SPACE ; hi-res text screen cursor character +; HGET/HPUT buffer header structure +HB.ADDR equ 0 ; address of next buffer (2 bytes) +HB.NUM equ 2 ; number of this buffer (1 byte) +HB.SIZE equ 3 ; number of bytes in this buffer (2 bytes) +HB.LEN equ 5 ; number of bytes in a buffer header +; Video register definitions +; INIT0 +COCO equ 0x80 ; 1 = Coco2 compatible mode +MMUEN equ 0x40 ; 1 = MMU enabled +IEN equ 0x20 ; 1 = IRQ enabled +FEN equ 0x10 ; 1 = FIRQ enabled +MC3 equ 0x08 ; 1 = FExx constant page enabled +MC2 equ 0x04 ; 1 = Standard SCS operation +MC1 equ 0x02 ; ROM map control bit 1 +MC0 equ 0x01 ; ROM map control bit 0 +; Interrupt enable/status bits +TMR equ 0x20 ; TIMER +HBORD equ 0x10 ; horizontal border +VBORD equ 0x08 ; vertical border +EI2 equ 0x04 ; serial data +EI1 equ 0x02 ; keyboard +EI0 equ 0x01 ; cartridge port +; Memory block definitions +BLOCK6.0 equ 0x30 ; hi-res graphics screen +BLOCK6.1 equ 0x31 ; hi-res graphics screen +BLOCK6.2 equ 0x32 ; hi-res graphics screen +BLOCK6.3 equ 0x33 ; hi-res graphics screen +BLOCK6.4 equ 0x34 ; HGET/HPUT buffers +BLOCK6.5 equ 0x35 ; stack space for hi-res graphics operations +BLOCK6.6 equ 0x36 ; hi-res text screen +BLOCK6.7 equ 0x37 ; unused by Basic +BLOCK7.0 equ 0x38 ; standard 64K memory map +BLOCK7.1 equ 0x39 ; standard 64K memory map +BLOCK7.2 equ 0x3a ; standard 64K memory map +BLOCK7.3 equ 0x3b ; standard 64K memory map +BLOCK7.4 equ 0x3c ; standard 64K memory map +BLOCK7.5 equ 0x3d ; standard 64K memory map +BLOCK7.6 equ 0x3e ; standard 64K memory map +BLOCK7.7 equ 0x3f ; standard 64K memory map (constant page comes from this block) +; Disk Basic FAT data format. The memory image contains a six byte header followed by the cached copy +; of the FAT from the disk. The cached copy may be modified compared to the copy on disk. This is indicated +; by a nonzero of the "FAT1" byte. +FAT0 equ 0 ; active file counter for this image +FAT1 equ 1 ; data changed flag - nonzero means write is needed +FATCON equ 6 ; offset to start of FAT data +; Directory entry format. Entries are 32 bytes long but only the first 16 are used. +DIRNAM equ 0 ; file name (8 characters) +DIREXT equ 8 ; extention (3 characters) +DIRTYP equ 11 ; file type number +DIRASC equ 12 ; ASCII flag +DIRGRN equ 13 ; first granule number for the file +DIRLST equ 14 ; number of bytes used in last sector (two bytes are needed) +; File control block format. +FCBTYP equ 0 ; file type: 0x40=RANDOM, 0x20=WRITE, 0x10=READ +FCBDRV equ 1 ; drive number +FCBFGR equ 2 ; first granule in the file +FCBCGR equ 3 ; current granule being used +FCBSEC equ 4 ; current sector within granule +FCBCPT equ 5 ; input file - next char to be read; output: sector full flag (sequential) +FCBPOS equ 6 ; current print position (0 for random files) +FCBREC equ 7 ; current record number (random files) +FCBRLN equ 9 ; random file record length +FCBBUF equ 11 ; pointer to the start of this files buffer +FCBSOF equ 13 ; sector offset to current position in the record +FCBFLG equ 15 ; GET/PUT flag +FCBCFL equ 16 ; cache flag: nonzero is cache full (sequential) +FCBCDT equ 17 ; cache byte (sequential) +FCBDIR equ 18 ; directory entry number +FCBLST equ 19 ; number of bytes in last sector of the file +FCBGET equ 21 ; GET record counter (how many pulled from record) +FCBPUT equ 23 ; PUT record counter (where to put next byte in record) +FCBDFL equ 23 ; input file: data left flag (nonzero is no data) +FCBLFT equ 24 ; number of characters left in input file buffer +FCBCON equ 25 ; offset to data buffer +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; This is the memory map and variable definitions for the entire system (all levels of Basic) +; NOTE: unnamed variables (Vxx) are generally scratch variables used for various purpose. As such, no further description is +; provided for those. + org 0 + setdp 0 +ENDFLG rmb 1 ; STOP/END flag: bit 7 set means STOP, bit 7 clear means END +CHARAC rmb 1 ; terminator character for searches +ENDCHR rmb 1 ; terminator character for searches +TMPLOC rmb 1 ; scratch variable +IFCTR rmb 1 ; number of "IF" statements encountered while scanning a line +DIMFLG rmb 1 ; nonzero means dimensioning, zero means evaluating (when parsing array) +VALTYP rmb 1 ; the type of the current value when evaluating expressions +GARBFL rmb 1 ; flag for whether garbage collection has been done yet when allocating strings +ARYDIS rmb 1 ; nonzero means don't parse arrays when parsing variables +INPFLG rmb 1 ; are we running INPUT or READ - nonzero for INPUT +RELFLG rmb 1 ; which relational operators are currently in play +TEMPPT rmb 2 ; pinter to the top of the string stack +LASTPT rmb 2 ; pointer to the last entry on the string stack +TEMPTR rmb 2 ; scratch pointer +TMPTR1 rmb 2 ; scratch pointer +FPA2 rmb 4 ; floating point accumulator, mantissa only +BOTSTK rmb 2 ; bottom of stack during last check; also a scratch variable +TXTTAB rmb 2 ; pointer to the beginning of the program +VARTAB rmb 2 ; pointer to the beginning of the scalar variable table (end of program) +ARYTAB rmb 2 ; pointer to the beginning of the array table (end of scalars) +ARYEND rmb 2 ; pointer to the end of the array table (start of free memory) +FRETOP rmb 2 ; top of free memory (start of string space) +STRTAB rmb 2 ; start of allocates string space +FRESPC rmb 2 ; pointer to newly allocated string space +MEMSIZ rmb 2 ; top of memory (and string space) allowed for the interpreter to size +OLDTXT rmb 2 ; save line number during STOP +BINVAL rmb 2 ; binary value of line number during parsing +OLDPTR rmb 2 ; saving input pointer during STOP +TINPTR rmb 2 ; temporary input pointer storage +DATTXT rmb 2 ; line number where we're looking for DATA +DATPTR rmb 2 ; input pointer where we're looking for DATA +DATTMP rmb 2 ; scratch pointer for INPUT and READ +VARNAM rmb 2 ; storage for variable name during parsing +VARPTR rmb 2 ; pointer to variable descriptor +VARDES rmb 2 ; pointer to variable descriptor +RELPTR rmb 2 ; pointer to relational operator processing routine +TRELFL rmb 1 ; temporary relational operator flags +V40 rmb 1 +V41 rmb 1 +V42 rmb 1 +V43 rmb 1 +V44 rmb 1 +V45 rmb 1 +V46 rmb 1 +V47 rmb 1 +V48 rmb 2 +V4A rmb 1 +V4B rmb 2 +V4D rmb 2 +FP0EXP rmb 1 ; floating point accumulator #0 exponent +FPA0 rmb 4 ; floating point accumulator #0 mantissa +FP0SGN rmb 1 ; floating point accumulator #0 sign +COEFCT rmb 1 ; polynomial expansion coefficient counter +STRDES rmb 5 ; temporary string descriptor +FPCARY rmb 1 ; floating point carry byte +FP1EXP rmb 1 ; floating point accumulator #1 exponent +FPA1 rmb 4 ; floating point accumulator #1 mantissa +FP1SGN rmb 1 ; floating point accumulator #1 sign +RESSGN rmb 1 ; pre-calculated result sign +FPSBYT rmb 1 ; floating point extra precision underflow byte +COEFPT rmb 2 ; polynomial expansion coefficient pointer +LSTTXT rmb 2 ; current line pointer during LIST +CURLIN rmb 2 ; line number of currently executing statement (0xffff for direct) +DEVCFW rmb 1 ; width of tab field for current device +DEVLCF rmb 1 ; column of last tab field for current device +DEVPOS rmb 1 ; current output column for current device +DEVWID rmb 1 ; number of characters per line for current device +PRTDEV rmb 1 ; print device flag: 0xff for non-display device (tape) +DEVNUM rmb 1 ; current I/O device/file number (signed) +CINBFL rmb 1 ; EOF flag for console in (0xff for EOF) +RSTFLG rmb 1 ; warm start enable flag: 0x55 for enabled +RSTVEC rmb 2 ; pointer to warm start routine (must start with NOP) +TOPRAM rmb 2 ; the actual top of memory + rmb 2 ; *unused* +FILSTA rmb 1 ; status of tape file (0=closed, 1=input, 2=output) +CINCTR rmb 1 ; number of characters in buffer +CINPTR rmb 2 ; pointer to current buffer location +BLKTYP rmb 1 ; cassette block type +BLKLEN rmb 1 ; length of cassette block +CBUFAD rmb 2 ; pointer to data buffer for cassette I/O +CCKSUM rmb 1 ; cassette checksum +CSRERR rmb 1 ; cassette error flag/charactercount +CPULWD rmb 1 ; pulse width counter +CPERTM rmb 1 ; bit counter +CBTPHA rmb 1 ; sync phase flag +CLSTSN rmb 1 ; last sine table entry +GRBLOK rmb 1 ; graphic block value for SET/RESET/POINT +IKEYIM rmb 1 ; cached key read during BREAK check +CURPOS rmb 2 ; screen cursor position +ZERO rmb 2 ; always kept as 0 +SNDTON rmb 1 ; tone value for SOUND +SNDDUR rmb 2 ; duration value for SOUND +CMPMID rmb 1 ; 1200/2400 Hz partition (why is this a variable?) +CMP0 rmb 1 ; upper limit of 1200 Hz period (why is this a variable?) +CMP1 rmb 1 ; upper limit of 2400 Hz period (why is this a variable?) +SYNCLN rmb 2 ; number of 0x55s for a cassette leader (why is this a variable?) +BLKCNT rmb 1 ; cursor blink delay counter +LPTBTD rmb 2 ; serial baud rate delay count +LPTLND rmb 2 ; delay for waiting for carriage return +LPTCFW rmb 1 ; tab field width for printer +LPTLCF rmb 1 ; last tab field position for printer +LPTWID rmb 1 ; width of printer line +LPTPOS rmb 1 ; current character position for printer +EXECJP rmb 2 ; default jump address for EXEC +GETNCH rmb 6 ; fetch next character for interpretation (INC CHARAD+1\BNE GETCCH\INC CHARAD) +GETCCH rmb 1 ; re-fetch the current character for interpretation (opcode of LDA extended) +CHARAD rmb 2 ; current input pointer + rmb 3 ; (JMP BROMHK) +VAB rmb 1 +VAC rmb 1 +VAD rmb 1 +VAE rmb 1 +TRCFLG rmb 1 ; is TRACE enabled? nonzero is on +USRADR rmb 2 ; address of the start of USR vectors +FORCOL rmb 1 ; bitmap foreground colour +BAKCOL rmb 1 ; bitmap background colour +WCOLOR rmb 1 ; bitmap working colour +ALLCOL rmb 1 ; byte with all pixels set to WCOLOR +PMODE rmb 1 ; which PMODE is active +ENDGRP rmb 2 ; end of current bitmap graphics page +HORBYT rmb 1 ; number of bytes per bitmap row +BEGGRP rmb 2 ; start of current bitmap graphics page +GRPRAM rmb 1 ; MSB of start of bitmap graphics +HORBEG rmb 2 ; horizontal starting coordinate +VERBEG rmb 2 ; vertical starting coordinate +CSSVAL rmb 1 ; SCREEN's colour set value +SETFLG rmb 1 ; doing PSET or PRESET? (nonzero = PSET) +HOREND rmb 2 ; horizontal ending coordinate +VEREND rmb 2 ; vertical ending coordinate +HORDEF rmb 2 ; default horizontal coordinate +VERDEF rmb 2 ; default vertical coordinate +VCB rmb 2 +VCD rmb 2 +VCF rmb 2 +VD1 rmb 2 +VD3 rmb 1 +VD4 rmb 1 +VD5 rmb 1 +VD6 rmb 1 +VD7 rmb 1 +VD8 rmb 1 +VD9 rmb 1 +VDA rmb 1 +CHGFLG rmb 1 ; flag indicating if graphic data changed +TMPSTK rmb 2 ; temporary stack pointer during PAINT +OCTAVE rmb 1 ; PLAY octave +VOLHI rmb 1 ; PLAY high volume value +VOLLOW rmb 1 ; PLAY low volumnevalue +NOTELN rmb 1 ; PLAY notelength +TEMPO rmb 1 ; PLAY tempo +PLYTMR rmb 2 ; PLAY timer +DOTVAL rmb 1 ; PLAY dotted note timer scale factor +HRMODE equ * ; Coco3 graphics mode +DLBAUD rmb 1 ; DLOAD BAUD constant +HRWIDTH equ * ; Coco3 text mode +TIMOUT rmb 1 ; DLOAD timeout constant +ANGLE rmb 1 ; DRAW angle +SCALE rmb 1 ; DRAW scale +DCOPC rmb 1 ; DSKCON operation code +DCDRV rmb 1 ; DSKCON drive number +DCTRK rmb 1 ; DSKCON track number +DSEC rmb 1 ; DSKCON sector number +DCBPT rmb 2 ; DSKCON buffer pointer +DCSTA rmb 1 ; DSKCON status +FCBTMP rmb 2 ; temp file control block pointer + rmb 13 ; *unused* +SW3VEC rmb 3 ; SWI3 vector +SW2VEC rmb 3 ; SWI2 vector +SWIVEC rmb 3 ; SWI vector +NMIVEC rmb 3 ; NMI vector +IRQVEC rmb 3 ; IRQ vector +FRQVEC rmb 3 ; FIRQ vector +TIMVAL equ * ; Extended Basic TIMER value (2 bytes only) +USRJMP rmb 3 ; jump address for USR function +RVSEED rmb 5 ; floating point random number seed +CASFLG rmb 1 ; capslock state for keyboard +DEBVAL rmb 2 ; keyboar debounce delay (why is this a variable?) +EXPJMP rmb 3 ; exponentiation handler +COMVEC rmb 10 ; Color Basic's command table + rmb 10 ; Extended Basic's command table + rmb 10 ; Disk Basic's command table +USR0 rmb 20 ; ECB USR jump addresses (extra user command table and unused for Disk Basic) +KEYBUF rmb 8 ; keyboard state table +POTVAL rmb 4 ; joystick axis values (left vert, left horiz, right vert, right horiz) +RVEC0 rmb 3 ; RAM hook: OPEN +RVEC1 rmb 3 ; RAM hook: device number check +RVEC2 rmb 3 ; RAM hook: set print parameters +RVEC3 rmb 3 ; RAM hook: console out +RVEC4 rmb 3 ; RAM hook: console in +RVEC5 rmb 3 ; RAM hook: input device number check +RVEC6 rmb 3 ; RAM hook: output device number check +RVEC7 rmb 3 ; RAM hook: close all files +RVEC8 rmb 3 ; RAM hook: close current file +RVEC9 rmb 3 ; RAM hook: PRINT +RVEC10 rmb 3 ; RAM hook: INPUT +RVEC11 rmb 3 ; RAM hook: BREAK check +RVEC12 rmb 3 ; RAM hook: line input +RVEC13 rmb 3 ; RAM hook: terminating line input +RVEC14 rmb 3 ; RAM hook: EOF +RVEC15 rmb 3 ; RAM hook: expression evaluation +RVEC16 rmb 3 ; RAM hook: ERROR handler (on error goto) +RVEC17 rmb 3 ; RAM hook: ERROR handler (regular handling) +RVEC18 rmb 3 ; RAM hook: RUN +RVEC19 rmb 3 ; RAM hook: parse number +RVEC20 rmb 3 ; RAM hook: main interpretation loop +RVEC21 rmb 3 ; RAM hook: SET/RESET/POINT +RVEC22 rmb 3 ; RAM hook: CLS/ECB secondary/RENUM token/GET/PUT +RVEC23 rmb 3 ; RAM hook: crunch line +RVEC24 rmb 3 ; RAM hook: uncrunch line +STRSTK rmb 8*5 ; string stack +CFNBUF rmb 9 ; cassette file name buffer +CASBUF rmb 256 ; cassette I/O buffer +LINHDR rmb 2 ; header for line input (holds line number when editing program) +LINBUF rmb LBUFMX+1 ; line input buffer +STRBUF rmb 41 ; temporary string buffer +VIDRAM rmb 0x200 ; VDG text screen +DBUF0 rmb SECLEN ; Main disk I/O buffer +DBUF1 rmb SECLEN ; Secondary disk I/O buffer (used for VERIFY) +FATBL0 rmb FATLEN ; File allocation table cache for drive 0 +FATBL1 rmb FATLEN ; File allocation table cache for drive 1 +FATBL2 rmb FATLEN ; File allocation table cache for drive 2 +FATBL3 rmb FATLEN ; File allocation table cache for drive 3 +FCBV1 rmb 16*2 ; FCB pointers +RNBFAD rmb 2 ; start of free random file buffer area +FCBADR rmb 2 ; start of file control blocks +DNAMBF rmb 8 ; disk file name buffer +DEXTBF rmb 3 ; disk file name extension buffer +DFLTYP rmb 1 ; disk file type (0=Basic, 1=Data, 2=M/L) +DASCFL rmb 1 ; disk file ASCII flag (0=binary, 0xff=ASCII) +DRUNFL rmb 1 ; RUN flag (bit 1 set then RUN, bit 0 set then close files) +DEFDRV rmb 1 ; default drive number +FCBACT rmb 1 ; number of active file control blocks +DRESFL rmb 1 ; reset flag - will cause all FCBs to be shut down +DLODFL rmb 1 ; load flag - cause a "NEW" on error +DMRGFL rmb 1 ; merge flag: nonzero means we're merging +DUSRVC rmb 20 ; Disk Basic USR addresses +V973 rmb 1 +V974 rmb 2 +V976 rmb 1 +V977 rmb 1 +V978 rmb 2 +WFATVL rmb 2 ; number of granules allocated to trigger a FAT cache write +DFFLEN rmb 2 ; direct access file recrod length +DR0TRK rmb 4 ; current track number for each drive +NMIFLG rmb 1 ; nonzero means NMI vectoring is enabled +DNMIVC rmb 2 ; address to vector to in NMI +RDYTMR rmb 1 ; number of ticks before turning off drive motors +DRGRAM rmb 1 ; cached value of write-only disk control register +DVERFL rmb 1 ; nonzero means write verifies on +ATTCTR rmb 1 ; read/write attempt counter +DFLBUF equ * ; start of random file area, FCBs, etc. + + + org 0x8000 +EXBAS rmb 0x2000 ; Extended Basic ROM area +BASIC rmb 0x2000 ; Color Basic ROM area +ROMPAK equ * ; external ROM address +DOSBAS rmb 0x2000 ; Disk Basic ROM area + rmb 0x1e00 ; Super Extended Basic ROM area +; These are the variables used by SECB on the "constant FExx page" which is unaffected by the MMU +; when the FExx bit in INIT0 is set. +H.CRSLOC rmb 2 ; current cursor location pointer (hi-res) +H.CURSX rmb 1 ; current X coordinate of the cursor (hi-res) +H.CURSY rmb 1 ; current Y coordinate of the cursor (hi-res) +H.COLUMN rmb 1 ; the number of columns on the screen (hi-res) +H.ROW rmb 1 ; the number of rows on the screen (hi-res) +H.DISPEN rmb 2 ; pointer to the end of the screen (hi-res) +H.CRSATT rmb 1 ; current cursor attributes (hi-res) + rmb 1 ; *unused* +H.FCOLOR rmb 1 ; foreground colour (hi-res) +H.BCOLOR rmb 1 ; background colour (hi-res) +H.ONBRK rmb 2 ; ON BRK GOTO line number +H.ONERR rmb 2 ; ON ERR GOTO line number +H.ERROR rmb 1 ; most recent error number encountered (-1 for no error) +H.ONERRS rmb 2 ; line number where ON ERR GOTO was encountered +H.ERLINE rmb 2 ; line number where error actually occurred +H.ONBRKS rmb 2 ; line number where ON BRK GOTO was encountered +H.ERRBRK rmb 1 ; flag for whether we're processing an error or a break event +H.PCOUNT rmb 1 ; number of characters in the HPRINT buffer +H.PBUF rmb 80 ; HPRINT line buffer (max 80 characters per line) + rmb 132 ; *unused* +; This is the set of primary interrupt vectors on the Coco3. These are here so that systems other +; than Basic do not have to rely on low memory remaining constant. Under Basic, these simply bounce +; to the traditional vectors starting at 0x100. +INT.FLAG rmb 1 ; interrupt vector validity flag: 0x55 for valid +INT.JUMP equ * +INT.SWI3 rmb 3 ; SWI3 bounce vector +INT.SWI2 rmb 3 ; SWI2 bounce vector +INT.FIRQ rmb 3 ; FIRQ bounce vector +INT.IRQ rmb 3 ; IRQ bounce vector +INT.SWI rmb 3 ; SWI bounce vector +INT.NMI rmb 3 ; NMI bounce vector +; This is that start of the I/O page. Everything above here is hardware defined. +PIA0 rmb 4 ; PIA0 (keyboard/joystick) + rmb 28 ; PIA0 images (due to sloppy-ass decode) +DA equ * ; DAC address +PIA1 rmb 4 ; PIA1 (misc hardware) + rmb 28 ; PIA1 images (due to sloppy-ass decode) +DSKREG rmb 1 ; Disk control register + rmb 7 ; images of DSKREG due to (sloppy-ass decode) +FDCREG rmb 1 ; FDC command/status register + rmb 1 ; FDC track register + rmb 1 ; FDC sector register + rmb 1 ; FDC data register + rmb 4 ; mirror of FDCREG + rmb 16 ; unused SCS area + rmb 32 ; misc hardware area + rmb 16 ; *coco3 reserved* +INIT0 rmb 1 ; GIME initialization register 0 +INIT1 rmb 1 ; GIME initialization register 1 +IRQENR rmb 1 ; GIME IRQ enable/status register +FIRQENR rmb 1 ; GIME FIRQ enable/status register +V.TIMER rmb 2 ; GIME timer setting + rmb 2 ; *reserved* +VIDEOMOD rmb 1 ; GIME video mode register +VIDEORES rmb 1 ; GIME video resolution register +V.BORDER rmb 1 ; GIME border colour register + rmb 1 ; *reserved* +V.SCROLL rmb 1 ; GIME vertical scroll register +V.OFFSET rmb 2 ; GIME vertical offset (screen address) register +H.OFFSET rmb 1 ; GIME horizontal offset register +MMUREG rmb 16 ; GIME MMU registers (two tasks of 8) +PALETREG rmb 16 ; GIME palette registers +SAMREG equ * ; the SAM registers +V0CLR rmb 1 ; SAM video mode bits +V0SET rmb 1 +V1CLR rmb 1 +V1SET rmb 1 +V2CLR rmb 1 +V2SET rmb 1 +F0CLR rmb 1 ; SAM screen address bits +F0SET rmb 1 +F1CLR rmb 1 +F1SET rmb 1 +F2CLR rmb 1 +F2SET rmb 1 +F3CLR rmb 1 +F3SET rmb 1 +F4CLR rmb 1 +F4SET rmb 1 +F5CLR rmb 1 +F5SET rmb 1 +F6CLR rmb 1 +F6SET rmb 1 + rmb 2 ; *reserved* +R0CLR rmb 1 ; SAM R0 bit (address dependent speedup) +R0SET rmb 1 +R1CLR rmb 1 ; SAM R1 bit (full speedup/coco3 speedup) +R1SET rmb 1 + rmb 4 ; *reserved* +TYCLR rmb 1 ; force ROM mode +TYSET rmb 1 ; set RAM mode + rmb 18 ; *MPU reserved* +SWI3 rmb 2 ; MPU SWI3 vector +SWI2 rmb 2 ; MPU SWI2 vector +FIRQ rmb 2 ; MPU FIRQ vector +IRQ rmb 2 ; MPU IRQ vector +SWI rmb 2 ; MPU SWI vector +NMI rmb 2 ; MPU NMI vector +RESETV rmb 2 ; MPU reset vector
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/disk.s Sat Dec 08 19:57:01 2018 -0700 @@ -0,0 +1,3566 @@ + *pragma nolist + include defs.s +; Various references to Color Basic and Extended Color Basic which are listed here to allow this ROM to be built independently. +XBWMST equ 0x80c0 +L813C equ 0x813c +L8168 equ 0x8168 +XVEC3 equ 0x8273 +XVEC8 equ 0x8286 +XVEC18 equ 0x829c +L8311 equ 0x8311 +L8316 equ 0x8316 +L836C equ 0x836c +L8748 equ 0x8748 +L880E equ 0x880e +XVEC15 equ 0x8846 +XVEC17 equ 0x88f0 +L8955 equ 0x8955 +L8C1B equ 0x8c1b +XVEC4 equ 0x8cf1 +XVEC9 equ 0x8e90 +L95AC equ 0x95ac +L962E equ 0x962e +L9650 equ 0x9650 +L96CB equ 0x96cb +L96EC equ 0x96ec +L975F equ 0x975f +L9FB5 equ 0x9fb5 +LA0E2 equ 0xa0e2 +BAWMST equ 0xa0e8 +LA171 equ 0xa171 +LA176 equ 0xa176 +PUTCHR equ 0xa282 +LA35F equ 0xa35f +LA37C equ 0xa37c +LA3ED equ 0xa3ed +LA3FB equ 0xa3fb +LA406 equ 0xa406 +LA426 equ 0xa426 +LA429 equ 0xa429 +LA42D equ 0xa42d +LA549 equ 0xa549 +LA59A equ 0xa59a +LA5A2 equ 0xa5a2 +LA5A5 equ 0xa5a5 +LA5AE equ 0xa5ae +LA5C7 equ 0xa5c7 +LA5DA equ 0xa5da +LA5E4 equ 0xa5e4 +LA603 equ 0xa603 +LA616 equ 0xa616 +LA61C equ 0xa61c +LA61F equ 0xa61f +LA928 equ 0xa928 +LA951 equ 0xa951 +LA7D1 equ 0xa7d1 +LA7E9 equ 0xa7e9 +LA974 equ 0xa974 +LAC37 equ 0xac37 +LAC44 equ 0xac44 +LAC46 equ 0xac46 +LAC60 equ 0xac60 +LAC73 equ 0xac73 +LAC7C equ 0xac7c +LACEF equ 0xacef +LAD19 equ 0xad19 +LAD21 equ 0xad21 +LAD33 equ 0xad33 +LAD9E equ 0xad9e +LADC6 equ 0xadc6 +LADD4 equ 0xadd4 +LADEB equ 0xadeb +LAE15 equ 0xae15 +LAF9A equ 0xaf9a +LAFA4 equ 0xafa4 +LAFB1 equ 0xafb1 +LB00C equ 0xb00c +LB01E equ 0xb01e +LB069 equ 0xb069 +LB143 equ 0xb143 +LB146 equ 0xb146 +LB148 equ 0xb148 +LB156 equ 0xb156 +LB244 equ 0xb244 +LB262 equ 0xb262 +LB166 equ 0xb166 +SYNCOMMA equ 0xb26d +LB26F equ 0xb26f +LB277 equ 0xb277 +LB2CE equ 0xb2ce +LB357 equ 0xb357 +LB3E6 equ 0xb3e6 +LB44A equ 0xb44a +LB4F3 equ 0xb4f3 +GIVABF equ 0xb4f4 +LB50F equ 0xb50f +LB516 equ 0xb516 +LB654 equ 0xb654 +LB657 equ 0xb657 +LB659 equ 0xb659 +LB69B equ 0xb69b +LB6A4 equ 0xb6a4 +EVALEXPB equ 0xb70b +LB70E equ 0xb70e +LB738 equ 0xb738 +LB73D equ 0xb73d +LIST equ 0xb764 +LB958 equ 0xb958 +LB95C equ 0xb95c +STRINOUT equ 0xb99c +LB99F equ 0xb99f +LB9A2 equ 0xb9a2 +LB9AC equ 0xb9ac +LB9AF equ 0xb9af +LB9C5 equ 0xb9c5 +LBB91 equ 0xbb91 +LBC14 equ 0xbc14 +LBC33 equ 0xbc33 +LBC35 equ 0xbc35 +LBC5F equ 0xbc5f +INT equ 0xbcee +LBDCC equ 0xbdcc +LBDD9 equ 0xbdd9 + pragma noexpandcond + *pragma list +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; DISK EXTENDED COLOR BASIC +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ifeq DISKVER +DHITOK equ 0xe0 ; highest command token +CYEAR equ '1 ; ones digit of copyright year +MINORVER equ '0 + else +DHITOK equ 0xe1 ; highest command token +CYEAR equ '2 ; ones digit for copyright year +MINORVER equ '1 + endc + org DOSBAS + fcc 'DK' ; magic number Extended Basic uses to identify the presence of a Disk ROM +LC002 bra LC00C ; entry point - jump around vector table +DCNVEC fdb DSKCON ; DSKCON indirect entry point +DSKVAR fdb DCOPC ; address of DSKCON parameter block + ifeq DISKVER-1 +DSINIT fdb DOSINI ; vector to an initialization routine, the utility of which is unclear +DOSVEC fdb DOSCOM ; pointer to the actual location of the DOS command + endc +LC00C ldx #DBUF0 ; point to start of Disk Basic memory +LC00F clr ,x+ ; clear a byte + cmpx #DFLBUF ; at end of statically allocated Disk Basic memory? + bne LC00F ; brif not + ldx #LC109 ; point to initializer for the command interpretation table + ldu #COMVEC+20 ; point to command interpretation table location for Disk Basic + ldb #10 ; ten bytes in each table entry + jsr LA59A ; initialize interpretation table + ldd #LB277 ; syntax error address + std 3,u ; set command handler for "user" table to error + std 8,u ; set function handler for "user" table to error + clr ,u ; mark user table with 0 command keywords + clr 5,u ; mark user table with 0 function keywords + ldd #DXCVEC ; intercept Extended Basic's command handler + std COMVEC+13 + ldd #DXIVEC ; intercept Extended Basic's function handler + std COMVEC+18 + ldu #RVEC0 ; point to first RAM vector +LC03B lda #0x7e ; op code of JMP extended + sta RVEC22 ; set first byte of GET/PUT vector to JMP + sta ,u+ ; set this vector to be a JMP instruction + ldd ,x++ ; get vector destination + std ,u++ ; set the vector destination + cmpx #LC139 ; done the whole list? + bne LC03B ; brif not + ldx #DVEC22 ; install handler for GET/PUT vector + stx RVEC22+1 + ifeq DISKVER-1 + ldx #DVEC20 ; install replacement interpretation loop handler + stx RVEC20+1 + endc + ldx #DUSRVC ; relocate USR vector table + stx USRADR + ldu #LB44A ; default USR address is illegal function call + ldb #10 ; there are 10 vectors +LC061 stu ,x++ ; set a vector + decb ; done all? + bne LC061 ; brif not + ldx #DNMISV ; install NMI handler + stx NMIVEC+1 + lda #0x7e ; make it a JMP + sta NMIVEC + ldx #DIRQSV ; install IRQ handler (ECB and CB already made it a JMP) + stx IRQVEC+1 + lda #19 ; initialze the number of changes needed to trigger a FAT write + sta WFATVL + clr FATBL0 ; mark all four FAT images as having no open files + clr FATBL1 + clr FATBL2 + clr FATBL3 + ldx #DFLBUF ; point to the start of the disk "heap" + stx RNBFAD ; set start of random file buffers as the end of the allocated space + leax 0x100,x ; allocate 256 bytes for random file buffers by default + stx FCBADR ; save start of FCBs (and end of random file buffers) + leax 1,x ; leave an empty byte before FCBs (why?) + stx FCBV1 ; set address of FCB 1 + clr <<FCBTYP,x ; mark it closed + leax FCBLEN,x ; set address of FCB 2 (2 user FCBs allocated at startup) + stx FCBV1+2 + clr <<FCBTYP,x ; mark it closed + leax FCBLEN,x ; set address of FCB 3 (system FCB) + stx FCBV1+4 + clr <<FCBTYP,x ; mark it closed + lda #2 ; set 2 active FCBs + sta FCBACT + leax FCBLEN,x ; point to end of active FCBs + tfr x,d ; put it in D so we can do stuff with it + tstb ; is it a partial memory page? + ifeq DISKVER + beq LC0C2 ; brif not + else + beq LC0BD ; brif not + endc + inca ; round up + ifeq DISKVER-1 +LC0BD bita #1 ; is it even (multiple of 512)? + beq LC0C2 ; brif so + inca ; round up to even 512 byte boundary + endc +LC0C2 tfr a,b ; save start of graphics memory + addb #24 ; reserve 4 graphics pages + stb TXTTAB ; set start of program there + jsr L96EC ; do graphics initialization (A is the start of grahpics memory) + lda BEGGRP ; get start of current grahpics page + adda #6 ; make one page used + sta ENDGRP + ifeq DISKVER-1 + jsr [DSINIT] ; do the pointless initialization routine + endc + bsr LC0F0 ; initialize FDC stuff and interrupt any action underway + andcc #0xaf ; enable interrupts + ldx #LC139-1 ; point to sign on message + jsr STRINOUT ; show sign on + ldx #DKWMST ; install warm start handler + stx RSTVEC + jmp LA0E2 ; jump into mainline Color Basic +DKWMST nop ; flag warm start routine as valid + bsr LC0F0 ; initialize FDC variables and interrupt any action underway + jsr LD2D2 ; close files and do some other stuff + jmp XBWMST ; transfer control to ECB's warm start +LC0F0 clr NMIFLG ; reset the NMI handler vector + clr RDYTMR ; disable the drive timeout counter + clr DRGRAM ; turn off all drive selects and motors (RAM copy) + clr DSKREG ; turn off all drive selects and motors (real hardware) + lda #0xd0 ; send "force interrupt" to controller + sta FDCREG + exg a,a ; wait for status to stabilize + exg a,a + lda FDCREG ; clear the status indicator (no error handling - nothing useful to do anyway) + rts + ifeq DISKVER +LC109 fcb 19 ; number of keywords (commands) + else +LC109 fcb 20 ; number of keywords (commands) + endc + fdb LC192 ; keyword table (commands) + fdb LC238 ; handler (commands) + fcb 6 ; number of keywords (functions) + fdb LC219 ; keyboard table (functions) + fdb LC24E ; handler (functions) +LC113 fdb DVEC0,DVEC1,DVEC2 ; RAM hook handler addresses + fdb DVEC3,DVEC4,DVEC5 + fdb DVEC6,DVEC7,DVEC8 + fdb XVEC9,DVEC10,DVEC11 + fdb DVEC12,DVEC13,DVEC14 + fdb DVEC15,DVEC12,DVEC17 + fdb DVEC18 +; Sign on message +LC139 fcc 'DISK EXTENDED COLOR BASIC 1.' + fcb MINORVER + fcb 0x0d + fcc 'COPYRIGHT (C) 198' + fcb CYEAR + fcc ' BY TANDY' + fcb 0x0d + fcc 'UNDER LICENSE FROM MICROSOFT' + fcb 0x0d,0x0d,0x00 +; Keyword list (commands) +LC192 fcs 'DIR' ; 0xce + fcs 'DRIVE' ; 0xcf + fcs 'FIELD' ; 0xd0 + fcs 'FILES' ; 0xd1 + fcs 'KILL' ; 0xd2 + fcs 'LOAD' ; 0xd3 + fcs 'LSET' ; 0xd4 + fcs 'MERGE' ; 0xd5 + fcs 'RENAME' ; 0xd6 + fcs 'RSET' ; 0xd7 + fcs 'SAVE' ; 0xd8 + fcs 'WRITE' ; 0xd9 + fcs 'VERIFY' ; 0xda + fcs 'UNLOAD' ; 0xdb + fcs 'DSKINI' ; 0xdc + fcs 'BACKUP' ; 0xdd + fcs 'COPY' ; 0xde + fcs 'DSKI$' ; 0xdf + fcs 'DSKO$' ; 0xe0 + ifeq DISKVER-1 + fcs 'DOS' ; 0xe1 + endc +; Jump table (commands) +LC1F1 fdb DIR ; 0xce DIR + fdb DRIVE ; 0xcf DRIVE + fdb FIELD ; 0xd0 FIELD + fdb FILES ; 0xd1 FILES + fdb KILL ; 0xd2 KILL + fdb LOAD ; 0xd3 LOAD + fdb LSET ; 0xd4 LSET + fdb MERGE ; 0xd5 MERGE + fdb RENAME ; 0xd6 RENAME + fdb RSET ; 0xd7 RSET + fdb SAVE ; 0xd8 SAVE + fdb WRITE ; 0xd9 WRITE + fdb VERIFY ; 0xda VERIFY + fdb UNLOAD ; 0xdb UNLOAD + fdb DSKINI ; 0xdc DSKINI + fdb BACKUP ; 0xdd BACKUP + fdb COPY ; 0xde COPY + fdb DSKI ; 0xdf DSKI$ + fdb DSKO ; 0xe0 DSKO$ + ifeq DISKVER-1 + fdb DOS ; 0xe1 DOS + endc +; Keyword list (functions) +LC219 fcs 'CVN' ; 0xa2 + fcs 'FREE' ; 0xa3 + fcs 'LOC' ; 0xa4 + fcs 'LOF' ; 0xa5 + fcs 'MKN$' ; 0xa6 + fcs 'AS' ; 0xa7 (here to avoid conflict with ASC) +; Jump table (functions) +LC22C fdb CVN ; 0xa2 CVN + fdb FREE ; 0xa3 FREE + fdb LOC ; 0xa4 LOC + fdb LOF ; 0xa5 LOF + fdb MKN ; 0xa6 MKN$ + fdb LB277 ; 0xa7 AS (not actually a function) +; Command handler +LC238 cmpa #DHITOK ; is it a Disk Basic valid command? + bhi LC244 ; brif not + ldx #LC1F1 ; point to jump table + suba #0xce ; normalize Disk Basic tokens to 0 + jmp LADD4 ; return to mainline to execute command +; The next two instructions are completely pointless. If we get here, the comparison has already +; been done and the branch condition is the exact opposite of what brought us here. +LC244 cmpa #DHITOK ; is it a Disk Basic token? + lbls LB277 ; brif not + jmp [COMVEC+33] ; transfer control to user command handler +; Function handler +LC24E cmpb #(0xa7-0x80)*2 ; is it a Disk Basic function token? + bls LC256 ; brif so + jmp [COMVEC+38] ; transfer control to user handler if not +LC256 subb #(0xa2-0x80)*2 ; normalize Disk Basic tokens to 0 + pshs b ; save jump table offset + jsr LB262 ; evaluate parenthetical expression + puls b ; get back jump table offset + ldx #LC22C ; point to jump table + jmp LB2CE ; rejoin mainline code to transfer control +; Error handler +DVEC17 puls y ; get back original caller + jsr LAD33 ; reset some stuff like CONT + jsr LD2D2 ; clean up some Disk Basic stuff + pshs y,b ; put return address back and save error code + jsr DVEC7 ; close all files + puls b ; get back error code + cmpb #2*27 ; is it a Disk Basic error code? + lblo XVEC17 ; brif not - pass it to Extended Basic + leas 2,s ; dump the return address + jsr LA7E9 ; stop tape + jsr LA974 ; stop sound + clr DEVNUM ; reset output to screen + jsr LB95C ; do a newline + jsr LB9AF ; do a ? + ldx #LC290-2*27 ; point to error message table + jmp LAC60 ; rejoin mainline error handler +; Error strings (note that NE error is provided by Extended Basic) +LC290 fcc 'BR' ; 27 Bad record + fcc 'DF' ; 28 Disk full + fcc 'OB' ; 29 Out of buffer space + fcc 'WP' ; 30 Write protected + fcc 'FN' ; 31 Bad file name + fcc 'FS' ; 32 Bad file structure + fcc 'AE' ; 33 File already exists + fcc 'FO' ; 34 Field overflow + fcc 'SE' ; 35 Set to non-fielded string + fcc 'VF' ; 36 Verify error + fcc 'ER' ; 37 Input or write past end of record +BASEXT fcc 'BAS' ; default Basic program file extension +DEFEXT fcc ' ' ; default blank extension (three spaces) +DATEXT fcc 'DAT' ; default extension for data files +BINEXT fcc 'BIN' ; default extension for binary files +; "CLS" vector handler. Extended Basic also chose to use this vector as a way to hook into +; the GET/PUT commands, the RENUM token check, and the Extended Basic "functions as commands" +; interpretation scheme. Only the GET/PUT hook is used. Checking the caller address is hacky +; but unavoidable here. +DVEC22 pshs x,cc ; save scratch register and flags + ldx 3,s ; get caller address + cmpx #L975F ; is it coming from GET/PUT? + bne LC2BF ; brif not + cmpa #'# ; is it GET # or PUT # (disk file operations)? + beq LC2C1 ; brif so - don't return to mainline +LC2BF puls cc,x,pc ; restore scratch register, flags, and return to mainline +; GET/PUT handler for random file access +LC2C1 leas 5,s ; remove saved state from above and don't return to mainline + jsr LC82E ; evaluate device number and get FCB pointer + stx FCBTMP ; save the FCB pointer + clr FCBGET,x ; reset the get data pointer + clr FCBGET+1,x + clr FCBPUT,x ; reset the put data pointer + clr FCBPUT+1,x + clr FCBPOS,x ; reset print position + lda FCBDRV,x ; get drive number for the file + sta DCDRV ; set it as the DSKCON drive number + jsr GETCCH ; end of statement? + beq LC2EA ; brif so - use current record + jsr SYNCOMMA ; insist on a comma + ifeq DISKVER + jsr LB3E6 ; evaluate expression to D + else + jsr LB73D ; get unsigned 16 bit number to X + tfr x,d ; stash it in D so we can use X as a pointer + endc +LC2E6 ldx FCBTMP ; get back FCB pointer + std FCBREC,x ; set the current record number + ifeq DISKVER +LC2EA jsr LC685 ; bump record number + else +LC2EA ldd FCBREC,x ; get desired record number + beq LC30B ; brif 0 - records start at 1 + jsr LC685 ; bump record number + endc + ldd FCBRLN,x ; get record length + ldx FCBBUF,x ; point to FCB data buffer + pshs x,b,a ; save them + leax -2,u ; point to record number (but zero based) + jsr L9FB5 ; do unsigned multiply of record length and record number + pshs u,y ; save product (this is the file offset to the record) + lda ,s+ ; is MSB 0? + bne LC30B ; brif not - record number too big + puls x ; middle two bytes are sector number in file - retrieve it + puls b ; LSB is offset into the sector - retrieve it +LC306 cmpx #(35-1)*18 ; is it more than the maximum number of sectors a file can have? + blo LC310 ; brif so +LC30B ldb #2*27 ; code for bad record + jmp LAC46 ; raise error +LC310 ldu FCBTMP ; get pointer to FCB + cmpx FCBSOF,u ; is it the same sector we're already handling? + lbeq LC3CF ; brif so + pshs x,b ; save sector number and sector offset + lda FCBFLG,u ; were we doing get or put? + beq LC324 ; brif we were doing get + clr FCBFLG,u ; flag doing get + ldb #3 ; write operation code for DSKCON + bsr LC357 ; write the sector data +LC324 ldd 1,s ; get sector number + jsr LC784 ; convert to a granule offset + pshs b ; save granule offset + jsr LC779 ; calculate starting sector of granule number + negb ; make negative + addb 3,s ; add LS byte of sector number + incb ; add one - sectors in FCB start at 1 + stb FCBSEC,u ; set sector + ldb FCBFGR,u ; get first granule in file + jsr LC755 ; fetch FAT pointer + leau FATCON,x ; point to actual granule table + lda ,s ; get number of granules offset to the record + inca ; bump it (compensate for deca below) +LC33E leax ,u ; point X to entry for this granule + abx + deca ; are we at the correct one? + beq LC37B ; bif not + stb ,s ; save granule offset on stack + ldb ,x ; get next granule in file + cmpb #0xc0 ; is it "end of file" flag? + blo LC33E ; brif not + ldb ,s ; get offset to previous granule + tst VD8 ; get or put? + bne LC366 ; brif put +LC352 ldb #2*23 ; code for input past end of file + jmp LAC46 ; raise error +LC357 leax FCBCON,u ; point to data buffer for FCB +LC35A stb DCOPC ; set operation code for DSKCON + stx DCBPT ; set buffer pointer for DSKCON + leax ,u ; point to FCB + jsr LC763 ; convert FCB track and sector to DSKCON parameters + jmp LD6F2 ; read or write the sector +LC366 pshs x,a ; save granule counter and pointer to last used granule + jsr LC7BF ; find a free granule + tfr a,b ; save allocated granule + puls a,u ; get last granule pointer and counter off stack + stb ,u ; add it to the file's granule chain + deca ; do we have enough of them? + bne LC366 ; brif not - allocate another + pshs x,b ; save alocated granule and pointer + jsr LC71E ; write the FAT out + puls b,x ; get back allocated granule and pointer +LC37B leas 1,s ; remove granule number + ldu FCBTMP ; point to FCB + stb FCBCGR,u ; save current granule + lda #0xff ; set to illegal sector offset to force sector data to be read + sta FCBSOF,u + lda ,x ; get next granule pointer + cmpa #0xc0 ; last granule? + blo LC3B2 ; brif not + anda #0x3f ; get only the number of sectors used + cmpa FCBSEC,u ; compare calculated sector to current sector + bhs LC3B2 ; brif sector is <= last one in file + lda VD8 ; GET or PUT? + beq LC352 ; brif GET - do IE error + lda FCBSEC,u ; get sector number from FCB + ora #0xc0 ; add "last granule" flag bits + sta ,x ; update FAT + jsr LC5A9 ; write FAT if needed + ldx FCBRLN,u ; get record length + cmpx #SECLEN ; exactly one sector? + bne LC3AD ; brif not + cmpx FCBLST,u ; is number of bytes in last sector a full sector? + beq LC3B2 ; brif so + lda #0x81 ; set "presaved" flag and force number of bytes to be 256 + skip1 ; skip next byte ("BRN") +LC3AD clra ; set number of bytes in last sector to 0 + clrb ; clear LS byte of D + std FCBLST,u ; set number of bytes used in last sector +LC3B2 ldb #2 ; DSKCON read operation + ldx FCBRLN,u ; get record length + cmpx #SECLEN ; exactly one sector? + bne LC3C8 ; brif not exactly + leas 7,s ; clean up stack + ldx FCBBUF,u ; point to start of random file buffer + lda VD8 ; is it GET or PUT? + beq LC3C5 ; brif GET + ldb #3 ; DSKCON write opreation +LC3C5 jmp LC35A ; go read or write a sector +LC3C8 jsr LC357 ; read a sector into data buffer + puls b,x ; get back byte offset to record + stx FCBSOF,u ; save sector offset +LC3CF pshs b ; save sector byte offset + jsr LC755 ; point to FAT + leax FATCON,x ; point to FAT data + ldb FCBCGR,u ; get current granulenumber + abx ; point to granule data + lda ,x ; get this granule's next pointer + cmpa #0xc0 ; end of file flag? + blo LC40A ; brif not + anda #0x3f ; convert to number of sectors in final granule + cmpa FCBSEC,u ; are we asking for the last sector? + bne LC40A ; brif not + ldd FCBLST,u ; get number of bytes in last sector + anda #0x7f ; lose pre-saved flag + pshs d ; save number of bytes in last sector + clra ; zero extend byte offset + ldb 2,s ; get byte offset + addd 3,s ; add in record length + cmpd ,s++ ; is it more than last sector? + bls LC40A ; brif the whole record fits + tst VD8 ; is it GET? + lbeq LC352 ; brif so - IE error if file doesn't have a whole record available + ifeq DISKVER + anda #1 ; keep only bit 0 of byte count + ora #0x80 ; set pre-saved flag bit + else + cmpd #SECLEN ; is it a whole sector we need? + bls LC405 ; brif not + ldd #SECLEN ; force one sector length +LC405 ora #0x80 ; set pre-saved flag bit + endc + std FCBLST,u ; save number of bytes in last sector +LC40A puls b ; get byte offset + leax FCBCON,u ; point to data buffer + abx ; offset into data buffer + ldu 2,s ; point to position in random file buffer + pshs b ; save byte offset + lda #-1 ; convert D into a negative 2 byte number representing unused bytes in sector + addd 1,s + bhs LC421 ; brif there are enough bytes to finish record + std 1,s ; save new temporary record length counter + puls b ; restore byte counter + negb ; negate it (B is number of bytes available to a record in this sector) + bra LC429 ; move the data +LC421 ldb 2,s ; get remaining record length + clr 1,s ; clear the temporary record length counter + clr 2,s + leas 1,s ; we no longer need byte offset +LC429 lda VD8 ; GET? + beq LC42F ; brif so + exg x,u ; swap pointers so we write to data buffer +LC42F jsr LA59A ; copy data + stu 2,s ; save new record pointer + ldu FCBTMP ; get pointer to FCB + lda VD8 ; GET? + beq LC43E ; brif so + sta FCBFLG,u ; flag as PUT + stx 2,s ; save buffer pointer +LC43E ldx FCBSOF,u ; get sector offset count + leax 1,x ; bump it + clrb ; byte offset in this new sector is 0 + ldu ,s ; get length of record needed + lbne LC306 ; brif not already completed ar ecord + puls a,b,x,pc ; clean up stack and return +; OPEN handler +DVEC0 leas 2,s ; don't return mainline + jsr LB156 ; evaluate mode expression + jsr LB6A4 ; get first character in the mode string + pshs b ; save it + jsr LA5A2 ; parse device number + tstb ; disk file? + lble LA603 ; return mainline if not disk file + puls a ; get mode + pshs a,b ; save mode and file number + clr DEVNUM ; reset device to screen + jsr SYNCOMMA ; insist on a comma + ldx #DATEXT ; point to "DAT" extension as default for data file + jsr LC938 ; parse file name + ldd #0x01ff ; file type is "data" (1) and ASCII + std DFLTYP ; save file type + ldx #SECLEN ; default record length - one whole sector + jsr GETCCH ; is there a record length specifier? + beq LC481 ; brif not + jsr SYNCOMMA ; insist on comma + jsr LB3E6 ; evaluate record length + ldx FPA0+2 ; get evaluated length +LC481 stx DFFLEN + lbeq LB44A ; record length of 0 makes no sense of error if so + jsr LA5C7 ; raise error if more stuff + puls a,b ; get mode and fil enumber +LC48D pshs a ; save mode + jsr LC749 ; point to FCB for this file + lbne LA61C ; brif the file is already open + stx FCBTMP ; save FCB pointer + jsr LC79D ; make sure FAT is valid + jsr LC68C ; search for requested file + puls b ; get mode + lda #INPFIL ; input file flag + pshs a ; save it + cmpb #'I ; input mode? + bne LC4C7 ; brif not + jsr LC6E5 ; see if match was found + jsr LC807 ; check if it's already open + ldx V974 ; point to directory data + ldd DIRTYP,x ; get file type and ASCII flag + std DFLTYP ; save it + bsr LC52D ; initialize FCB + jsr LC627 ; go read first sector from file +LC4BB jsr LC755 ; point to FAT + inc <<FAT0,x ; bump number of open files on this disk + ldx FCBTMP ; get back FCB pointer + puls a ; get file type + sta <<FCBTYP,x ; save file type + rts +LC4C7 asl ,s ; set type to output + cmpb #'O ; output requested? + bne LC4E8 ; brif not + tst V973 ; did file exist? + beq LC4E1 ; brif not + jsr LC6FC ; kill the old file + lda V973 ; get directory sector number of old file + sta V977 ; save as first free directory entry + ldx V974 ; get directory image of old file + stx V978 ; asve it as first free entry + ifeq DISKVER +LC4E1 bsr LC567 ; set up new directory entry on disk + else +LC4E1 jsr LC567 ; set up new directory entry on disk + endc + bsr LC538 ; initialize the file buffer + bra LC4BB ; finish setting up FCB +LC4E8 cmpb #'R ; random file? + beq LC4F2 ; brif so + cmpb #'D ; direct file? + lbne LA616 ; brif not - bad file mode +LC4F2 asl ,s ; set file type to random + ldd RNBFAD ; get address of random file buffer area + pshs d ; save it + addd DFFLEN ; add in record length + bcs LC504 ; brif we overflowed memory + cmpd FCBADR ; is it more than FCB data area? + bls LC509 ; brif not +LC504 ldb #2*29 ; code for out of buffer space + jmp LAC46 ; raise error +LC509 pshs d ; save new end of buffer area + tst V973 ; did the file exist? + bne LC514 ; brif so + bsr LC567 ; set up directory + ifeq DISKVER +LC514 bsr LC52D ; inistialize FCB + else + bra LC519 ; initialize FCB +LC514 lda #0xff ; set file type match = 0xff (all types) + jsr LC807 ; see if any open file matches and AO error if so +LC519 bsr LC52D ; initialize FCB + endc + com FCBSOF,x ; set FCBSOF to 0xff (illegal offset) to force new sector to be read + inc FCBREC+1,x ; set record number to 1 + puls a,b,u ; D = end of buffer, U = start of buffer + std RNBFAD ; save start of free buffer space + stu FCBBUF,x ; save buffer pointer in FCB + ldu DFFLEN ; get record length + stu FCBRLN,x ; save in FCB + bra LC4BB ; finish setting things up +LC52D bsr LC538 ; initialize FCB + ldu V974 ; get directory image + ldu DIRLST,u ; get number of bytes in last sector + stu FCBLST,x ; save it + rts +LC538 ldx FCBTMP ; get FCB pointer + ldb #FCBCON ; number of control bytes +LC53C clr ,x+ ; clear a control byte + decb ; done all? + bne LC53C ; brif not + ldx FCBTMP ; get back FCB pointer + lda DCDRV ; set drive number + sta FCBDRV,x + lda V976 ; get first granule + sta FCBFGR,x ; save it in FCB + sta FCBCGR,x ; also set as current granule + ldb V973 ; get directory sector offset + subb #3 ; directory sectors start at 3 + aslb ; 8 directory entries per sector + aslb + aslb + pshs b ; save sector offset + ldd V974 ; get directory pointer + subd #DBUF0 ; calculate offset in sector buffer + lda #8 ; 8 directory entries per sector + mul ; now A contains 0 to 7 + adda ,s+ ; add to directory sector offset + sta FCBDIR,x ; save directory entry number in FCB + rts +LC567 ldb #28*2 ; code for disk full + lda V977 ; get sector number of first empty entry + lbeq LAC46 ; brif none found + sta V973 ; save sector number of first entry + sta DSEC ; set DSKCON sector parameter + ldb #2 ; DSKCON read operation + stb DCOPC + jsr LD6F2 ; read sector + ldx V978 ; get address of RAM image of unused directory + stx V974 ; save as current entry + leau ,x ; point to directory image + ldb #DIRLEN ; set counter to clear the entry +LC586 clr ,x+ ; clear a byte + decb ; done all? + bne LC586 ; brif not + ldx #DNAMBF ; point to file name + ldb #11 ; 8.3 total number of characters + jsr LA59A ; copy file name into directory + ldd DFLTYP ; get file type and ASCII flag + std <<0,u ; save in directory + ldb #33 ; first granule to check + jsr LC7BF ; find first gree granule + sta V976 ; save granule found + sta 2,u ; save as first granule in file + ldb #3 ; DSKCON write operation + stb DCOPC + jsr LD6F2 ; write out directory entry +LC5A9 pshs u,x,b,a ; save registers + jsr LC755 ; point to FAT + inc FAT1,x ; mark FAT as changed + lda FAT1,x ; have enough things changed? + cmpa WFATVL + blo LC5BA ; brif not + jsr LC71E ; write FAT out +LC5BA puls a,b,x,u,pc ; restore registers and return +; Generic input handler +DVEC4 lda DEVNUM ; get device number + lble XVEC4 ; brif not disk file + leas 2,s ; don't return mainline if disk +LC5C4 pshs x,b ; save registers + clr CINBFL ; clear EOF flag + ldx #FCBV1-2 ; point to input file buffer table (-2 here to avoid decrementing device) + ldb DEVNUM ; get device number + aslb ; two bytes per pointer + ldx b,x ; get pointer to FCB + ldb FCBTYP,x ; get type of file + cmpb #RANFIL ; random file? + bne LC5EC ; brif not + ldd FCBGET,x ; get record counter + cmpd FCBRLN,x ; compare to size of record + bhs LC5FE ; brif pointer is after end of record - handle empty buffer + addd #1 ; move pointer forward + std FCBGET,x ; save new read pointer + ldx FCBBUF,x ; point to data buffer + leax d,x ; offset to buffer location + lda -1,x ; get the character (before the increment) + puls b,x,pc ; return the character from the record +LC5EC ldb FCBCFL,x ; has a character been "ungot"? + beq LC5F9 ; brif not + lda FCBCDT,x ; get ungot character + clr FCBCFL,x ; clear ungot flag + puls b,x,pc ; restore registers and return +LC5F9 ldb FCBDFL,x ; is there any data left to read? + beq LC602 ; brif so +LC5FE com CINBFL ; flag EOF + puls b,x,pc ; restore registers and return +LC602 ldb FCBCPT,x ; get character pointer + inc FCBCPT,x ; bump saved pointer + dec FCBLFT,x ; anything left? + beq LC611 ; brif buffer is empty + abx ; add offset into buffer + lda FCBCON,x ; get actual character (offset over the FCB control structure) + puls b,x,pc ; restore registers and return +LC611 pshs u,y ; save register + clra ; zero extend offset + leau d,x ; now U has buffer offset + lda FCBCON,u ; get character to return (offset over FCB control structure) + pshs a ; save return value + clr FCBCPT,x ; reset character pointer + lda FCBDRV,x ; set DSKCON to the correct drive + sta DCDRV + bsr LC627 ; read a sector + puls a,y,u ; restore registers and get back return value + puls b,x,pc ; restore registers and return +LC627 lda FCBSEC,x ; get current sector number +LC629 inca ; bump sector counter + pshs a ; save sector counter for later + cmpa #9 ; end of granule? + bls LC631 ; brif not + clra ; reset granule sector offset +LC631 sta FCBSEC,x ; save sector offset + ldb FCBCGR,x ; get granule number + leau ,x ; save FCB pointer + jsr LC755 ; point to correct FAT image + abx ; now X points to granule data + ldb FATCON,x ; get next granule pointer (offset past control data structure) + leax ,u ; reset FCB pointer + cmpb #0xc0 ; is the current granule the last one? + bhs LC64D ; brif so + puls a ; get sector number + suba #10 ; did it overflow the granule? + bne LC65E ; brif not + stb FCBCGR,x ; save new granule number + bra LC629 ; set variables for new granule +LC64D andb #0x3f ; get number of sectors in the granule + cmpb #9 ; is it more than a granule has? + bls LC658 ; brif not +LC653 ldb #2*32 ; code for bad file structure + jmp LAC46 ; raise error +LC658 subb ,s+ ; subtract current sector number and also clean stack + bcs LC67D ; brif past last sector + tfr b,a +LC65E pshs a ; save sector number difference + bsr LC685 ; bump record number + lda #2 ; set up for read + sta DCOPC + jsr LC763 ; set DSKCON variables for correct track and sector + leau FCBCON,x ; point past control structure to actual buffer + stu DCBPT ; set read destination + jsr LD6F2 ; go ahead and read the sector + clr FCBLFT,x ; set buffer left to full sector + ldb ,s+ ; get sector number back + bne LC684 ; brif not last sector + ldd FCBLST,x ; get bytes in last sector + bne LC681 ; brif bytes in last sector is nonzero +LC67D clrb ; set remaining bytes to 256 + com FCBDFL,x ; flag buffer empty +LC681 stb FCBLFT,x ; save number of bytes in buffer +LC684 rts +LC685 ldu FCBREC,x ; get current record number + leau 1,u ; bump it + stu FCBREC,x ; save new record number + rts +; Scan directory for file name; return sector number in V973, granule in V976, +; and pointer to directory data in V974. If disk is full, pointer in V978, +; and first unused sector in V977 (and V973 is 0) +LC68C clr V973 ; clear sector number (for not found) + clr V977 ; clear temp sector number + ldd #0x1102 ; set up to read track 17 + sta DCTRK + stb DCOPC + ldb #3 ; start with sector 3 +LC69B stb DSEC ; set DSKCON sector + ldu #DBUF0 ; read to global buffer + stu DCBPT + jsr LD6F2 ; read directory sector +LC6A5 stu V974 ; set pointer to directory entry data + leay ,u ; save start of directory entry + lda ,u ; NUL (for a deleted entry)? + bne LC6D6 ; brif not + bsr LC6D9 ; set unused pointers +LC6B0 ldx #DNAMBF ; point to desired file name +LC6B3 lda ,x+ ; does a character match? + cmpa ,u+ + bne LC6C7 ; brif not + cmpx #DNAMBF+11 ; end of file name? + bne LC6B3 ; brif not + stb V973 ; save sector number for match + lda FCBFGR,u ; set first granule in file + sta V976 + rts +LC6C7 leau DIRLEN,y ; point to next directory entry + cmpu #DBUF0+SECLEN ; end of sector? + bne LC6A5 ; brif not - search another + incb ; move to next sector + cmpb #11 ; 11 sectors in directory - checked all of them? + bls LC69B ; brif more sectors + rts +LC6D6 coma ; is first byte of file name 0xff? + bne LC6B0 ; brif not - actually do a search +LC6D9 lda V977 ; have we already found an unused entry? + bne DVEC12 ; brif so + stb V977 ; save sector number for unused entry + stu V978 ; save pointer to unused entry +DVEC12 rts ; NOTE: this is used as a dummy do-nothing RAM hook handler +LC6E5 ldb #2*26 ; code for NE error + tst V973 ; was entry found? + bne DVEC12 ; brif so + jmp LAC46 ; raise error +; KILL command +KILL jsr LC935 ; parse file name + jsr LA5C7 ; brif something after file name + jsr LC79D ; load FAT data + bsr LC68C ; look up file + bsr LC6E5 ; raise error if not found +LC6FC lda #0xff ; file type to match (all types) + jsr LC807 ; find any file that matches type + ldx V974 ; get directory entry pointer + clr ,x ; mark it as unused + ldb #3 ; set up to write + stb DCOPC + jsr LD6F2 ; write out the updated directory sector + ldb DIRGRN,x ; get starting granule of file +LC70F bsr LC755 ; point to correct FAT + leax FATCON,x ; skip control structure + abx ; now X points to next granule + ldb ,x ; get next granule pointer + lda #0xff ; mark granule free + sta ,x + cmpb #0xc0 ; was it last one? + blo LC70F ; brif not +; Write FAT to drive +LC71E ldu #DBUF0 ; point to global sector buffer + stu DCBPT ; point DSKCON there + ldd #0x1103 ; set up to write track 17 + sta DCTRK + stb DCOPC + ldb #2 ; FAT is in sector 2 + stb DSEC + bsr LC755 ; point to proper FAT entry + clr FAT1,x ; mark FAT as having no outstanding changes + leax FATCON,x ; move past control structure + ldb #GRANMX ; get total granule count in a FAT + jsr LA59A ; copy the FAT data to buffer + ifeq DISKVER +LC739 clr ,x+ ; clear a byte + cmpx #DBUF0+SECLEN ; end of sector? + else +LC739 clr ,u+ ; clear out the rest of the sector (to avoid junk going into it) + cmpu #DBUF0+SECLEN ; end of sector? + endc + ifeq DISKVER-1 + bne LC739 ; brif not + endc + jmp LD6F2 ; go write the FAT sector out +; Point X to the correct FCB based on DEVNUM (or B if entering at LC749) +LC744 pshs b ; save register + ldb DEVNUM ; get device number + skip2 +LC749 pshs b ; save register + lslb ; two bytes per pointer + ldx #FCBV1-2 ; point to FCB table (-2 to adjust for 1-based file numbers) + ldx b,x ; get pointer + ldb <<FCBTYP,x ; set flags for file type + puls b,pc ; restore register and return +; Point X to FAT image for the selected drive +LC755 pshs b,a ; save registers + lda DCDRV ; get drive number + ldb #FATLEN ; get size of FAT mirror + mul ; calculate offset from first FAT image + ldx #FATBL0 ; point to first FAT image + leax d,x ; offset to correct one + puls a,b,pc ; restore registers and return +; Set up DSKCON variables to point to the correct sector and track for the current file position +LC763 ldb FCBCGR,x ; get granule number + lsrb ; two granules per track + stb DCTRK ; save track + cmpb #17 ; is it below the directory? + blo LC76E ; brif so + inc DCTRK ; skip directory track if not +LC76E aslb ; double track number + negb ; subtract from actual granule number: -(TRK*2)+CGR + addb FCBCGR,x + bsr LC779 ; set B=9 for odd granule, B=0 for even + addb FCBSEC,x ; add granule sector offset + stb DSEC ; set DSKCON sector + rts +LC779 pshs b,a ; temp store original + aslb ; times 2 + rola + aslb ; times 4 + rola + aslb ; times 8 + rola + addd ,s++ ; times 9 + rts +; Convert sector offset in D to a granule offset (0-67) in B (lose fractional part) +LC784 clr ,-s ; make a temporary counter +LC786 inc ,s ; bump division counter + subd #90 ; does 90 go? + bpl LC786 ; brif so + lda ,s ; get quotient (+1) + stb ,s ; save remainder (negative) + ldb #10 ; multiply result by 10 (we divided by 90) + mul + puls a ; get back remainder +LC796 decb ; decrement granule count + adda #9 ; have we used up the remainder? + bmi LC796 ; brif not + clra ; zero extend result +LC79C rts +; Make sure FAT data is valid +LC79D bsr LC755 ; point to correct FAT + tst <<FAT0,x ; any open files? + bne LC79C ; brif so + clr FAT1,x ; reset change count + leau FATCON,x ; point past control structure + ldx #DBUF0 ; point DSKCON to sector buffer + stx DCBPT + ldd #0x1102 ; read track 17 + sta DCTRK + stb DCOPC + ldb #2 ; read sector 2 (FAT) + stb DSEC + jsr LD6F2 ; go read FAT + ldb #GRANMX ; get total FAT data size + jmp LA59A ; copy FAT data from sector buffer to FAT image +; Find free granule; enter with B containing the start location; mark granule with 0xc0 in the +; FAT to indicate last granule in file. Return granule number in A +LC7BF bsr LC755 ; get pointer to FAT + leax FATCON,x ; move past controls structure + clra ; reset granule counter + andb #0xfe ; start at first granule on track + clr ,-s ; initialize direction counter to down +LC7C8 com b,x ; is this granule free + beq LC7FD ; brif so + com b,x ; restore granule data + inca ; bump counter + cmpa #GRANMX ; searched whole FAT? + bhs LC7F8 ; brif so - disk full + incb ; bump granule counter + bitb #1 ; odd? + bne LC7C8 ; brif so + pshs b,a ; save granule counter and current granule + subb #2 ; move back one track + com 2,s ; flip direction + bne LC7EC ; brif we're switching to "up" + subb ,s+ ; subtract out granule counter (moves other side of start) + bpl LC7E8 ; brif below lower bound + ldb ,s ; get original granule number +LC7E6 com 1,s ; restore direction flag +LC7E8 leas 1,s ; remove saved granule number + bra LC7C8 ; see if we found a free granule yet +LC7EC addb ,s+ ; move to the top side of starting position + cmpb #GRANMX ; did we overflow upward? + blo LC7E8 ; brif not + ldb ,s ; get original granule number + subb #4 ; move an extra track in the other direction if overflowed up + bra LC7E6 ; go see if we found a free one yet +LC7F8 ldb #2*28 ; code for disk full + jmp LAC46 ; raise error +LC7FD leas 1,s ; clean up direction flag + tfr b,a ; put granule number in A + abx ; point X to granule data + ldb #0xc0 ; set granule to "used 0, last of file" + stb ,x +LC806 rts +; Check active files to see if a file is already open; drive number and granule number +; AO will not be generated if the current status matches *exactly* the requested type in A. +LC807 pshs a ; save desired file type + ldb FCBACT ; get number of active FCBs + incb ; include the system FCB in the check +LC80D jsr LC749 ; point to FCB + beq LC829 ; brif not open at all + lda DCDRV ; get desired drive + cmpa FCBDRV,x ; match? + bne LC829 ; brif not + ldu V974 ; get directory entry pointer + lda DIRGRN,u ; get first granule in file + cmpa FCBFGR,x ; does it match? + bne LC829 ; brif not + lda <<FCBTYP,x ; get file type + cmpa ,s ; does it match the type we want? + lbne LA61C ; brif not - raise AO error +LC829 decb ; checked all FCBs? + bne LC80D ; brif not + puls a,pc ; clean stack and return +; Parse device number and make sure it's open in random mode +LC82E jsr LA5A5 ; evaluate device number + clr DEVNUM ; reset device number to screen + tstb ; set flags on device number + lble LB44A ; brif not a disk file + jsr LC749 ; fetch FCB pointer + lda <<FCBTYP,x ; is file open? + lbeq LA3FB ; brif not + cmpa #RANFIL ; random file? + beq LC806 ; brif so +LC845 jmp LA616 ; raise bad file mode +; Input device number check handler +DVEC5 lda #INPFIL ; set to check for input file + skip2 +; Output device number check handler +DVEC6 lda #OUTFIL ; set to check for output file + tst DEVNUM ; set flags on device number + ble LC806 ; brif not a disk file (return) + stx ,s ; save X and lose return address + jsr LC744 ; point to FCB + ifeq DISKVER + pshs a ; save file type requested + else + pshs d ; save b and file type requested + endc + lda <<FCBTYP,x ; get file type + lbeq LA3FB ; brif not open + cmpa #RANFIL ; random file? + ifeq DISKVER + beq LC866 ; brif so - it's good (both input and output) + else + beq LC868 ; brif so - it's good (both input and output) + endc + cmpa ,s ; is it the right type? + bne LC845 ; brif not - bad file mode + ifeq DISKVER +LC866 puls a,x,pc ; restore registers and return + else +LC866 puls a,b,x,pc ; clean up stack, restore registers, and return to caller +; This code is required to work around the dumbosity in the INPUT command which outputs the +; prompt string uncondionally so it would cause the prompt string to end up being output to +; a random file. +LC868 ldx 4,s ; are we coming from INPUT? + cmpx #LB00C + bne LC866 ; brif not + jsr SYNCOMMA ; make sure there's a comma after device + cmpa #'" ; is there a prompt string? + bne LC881 ; brif not + jsr LB244 ; parse prompt string + jsr LB657 ; fetch string details (and discard them) + ldb #'; ; make sure there's a semicolon after the prompt string + jsr LB26F +LC881 ldx #LB01E ; return after the prompt string check + stx 4,s + puls a,b,x,pc ; return to mainline flow + endc +; Device number validity check handler + ifeq DISKVER +DVEC1 ble LC806 ; brif not a disk file + else +DVEC1 ble LC8AF ; brif not a disk file + endc + cmpb FCBACT ; is it in range for open files? + lbhi LA61F ; brif not - device number error + puls x,pc ; purge RAM hook call return and return to original caller +; Set print parameters handler +DVEC2 tst DEVNUM ; is it disk file? + ifeq DISKVER + ble LC806 ; brif not + else + ble LC8AF ; brif not + endc + leas 2,s ; don't return to mainline code + pshs x,b,a ; save registers + clr PRTDEV ; set print device to "display" + jsr LC744 ; point to correct FCB + ldb FCBPOS,x ; get print position + clra ; line width (256) + ldx #0x1000 ; tab width of 16, no last tab position + jmp LA37C ; go save print parameters +; LIST break check handler +DVEC11 tst DEVNUM ; is it disk file? + ble LC8AF ; brif not + leas 2,s ; purge return - don't do break check if disk file +LC8AF rts + ifeq DISKVER-1 +; Command interpreation handler +; This code replaces the main command interpretation loop completely. It includes a check +; to see if any keys are down before doing a break check. This is unneeded with Color Basic +; 1.2, but earlier versions of Color Basic benefit from it. This is the only change compared +; to plain ECB. +DVEC20 leas 2,s ; don't return to mainline code +LC8B2 andcc #0xaf ; enable interrupts + clr PIA0+2 ; strobe all keyboard columns + lda PIA0 ; get row data + coma ; invert bits so 1 means pressed + anda #0x7f ; lose the comparator input + beq LC8C2 ; brif no keys down - don't check for BREAK + jsr LADEB ; do a break check +LC8C2 ldx CHARAD ; get input pointer + stx TINPTR ; save it so things can find the start of this statement + lda ,x+ ; get current character + beq LC8D1 ; brif end of line + cmpa #': ; is it end of statement? + beq LC8F3 ; brif so + jmp LB277 ; raise syntax error if not end of statement +LC8D1 lda ,x++ ; get MSB of next line address + sta ENDFLG ; this sets ENDFLG to "END" (unless program code is above 0x7FFF) + bne LC8DA ; brif not end of program + jmp LAE15 ; go do "END" If we fell off the end of the program +LC8DA ldd ,x+ ; get line number for this line (and leave pointer one before line text) + std CURLIN ; set current line number + stx CHARAD ; set input pointer to start of line text + lda TRCFLG ; are we doing "TRON"? + beq LC8F3 ; brif not + lda #'[ ; show [ + jsr PUTCHR + lda CURLIN ; restore MSB of line number + jsr LBDCC ; show line number + lda #'] ; show ] + jsr PUTCHR +LC8F3 jsr GETNCH ; get starting character of next statement + tfr cc,b ; save flags + cmpa #0x98 ; CSAVE? + bne LC8FE ; brif not + jmp L8316 ; go handle ECB's CSAVE extensions (CSAVEM) +LC8FE cmpa #0x97 ; CLOAD? + bne LC905 ; brif not + jmp L8311 ; go handle ECB's CLOAD extensions (multi-origin binaries) +LC905 tfr b,cc ; restore flags for input byte + jsr LADC6 ; go interpret command token + bra LC8B2 ; process next statement + endc +; EOF handler +DVEC14 leas 2,s ; dont return to mainline code + lda DEVNUM ; get device number + pshs a ; save it + jsr LA5AE ; evaluate device number + jsr LA3ED ; make sure it's open for input + tst DEVNUM ; set flags on device + lble LA5DA ; brif not disk file - go to mainline code + jsr LC744 ; point to correct FCB + ldb <<FCBTYP,x ; get file type + cmpb #RANFIL ; is it random file? (have to check since random is valid for input) + ifeq DISKVER + beq LC845 ; bad file mode if so + else + lbeq LA616 ; bad file mode if so + endc + clrb ; set flag to not EOF (false) + lda FCBCFL,x ; is there an "ungot" character? + bne LC932 ; brif so + ldb FCBDFL,x ; is there anything in the buffer? Will be 0xff if not +LC932 jmp LA5E4 ; return status +; Parse a disk file name. Enter at LC938 with a pointer to the default extension in X. +; Valid file name patterns are: +; N:FILENAME[.EXT] +; N:FILENAME[/EXT] +; FILENAME[.EXT][:N] +; FILENAME[/EXT][:N] +; where N is a drive number. +LC935 ldx #DEFEXT ; point to blank default extension +LC938 clr ,-s ; set a flag for whether drive number was seen + lda DEFDRV ; set drive number to default (as set by DRIVE) + sta DCDRV + ldu #DNAMBF ; point to file name buffer + ldd #0x2008 ; space character and 8 characters to set +LC945 sta ,u+ ; blank a character + decb ; done all? + bne LC945 ; brif not + ldb #3 ; three characters in extension + jsr LA59A ; set default extension + jsr L8748 ; evaluate file name string + leau ,x ; point to start of the string + cmpb #2 ; is string less than 2 characters? + blo LC96A ; brif so - can't be N:FILENAME.EXT pattern + lda 1,u ; get second character + cmpa #': ; is it colon? + bne LC96A ; brif not - no leading drive number + lda ,u ; get leading character + cmpa #'0 ; is it below ASCII 0? + blo LC96A ; brif so - not a drive number + cmpa #'3 ; is it above ASCII 3? + bhi LC96A ; brif so - not a drive number + bsr LC99D ; get drive number +LC96A ldx #DNAMBF ; point to start of file name buffer + incb ; compensate for DECB below +LC96E decb ; end of string? + bne LC97D ; brif so + leas 1,s ; clean up drive number seen flag +LC973 cmpx #DNAMBF ; was there a file name? + bne LC9DF ; brif not +LC978 ldb #2*31 ; bad file name error code + jmp LAC46 ; raise error +LC97D lda ,u+ ; get character from string + cmpa #'. ; is it extension? + beq LC9B0 ; brif so + cmpa #'/ ; is it other extension introducer? + beq LC9B0 ; brif so + cmpa #': ; drive number introducer? + beq LC994 ; brif so + cmpx #DEXTBF ; are we at the end of the file name buffer? + beq LC978 ; brif so - name too long + bsr LC9D0 ; put character in file name + bra LC96E ; process another +LC994 bsr LC973 ; bad file name if no name yet + bsr LC99D ; parse drive number + tstb ; is there anything left? + bne LC978 ; brif so +LC99B puls a,pc ; clean up strack and return +LC99D com 2,s ; toggle drive number seen flag + beq LC978 ; brif we've seen drive number already + lda ,u++ ; get drive number and skip trailing : if leading + subb #2 ; take two characters from string + suba #'0 ; remove ASCII bias + blo LC978 ; brif not a digit + cmpa #3 ; is it in range? + bhi LC978 ; brif not + sta DCDRV ; save drive number + rts +LC9B0 bsr LC973 ; error if no file name yet + ldx #DFLTYP ; point to end of extension buffer + lda #0x20 ; space (for padding extension) +LC9B7 sta ,-x ; insert padding character + cmpx #DEXTBF ; done yet? + bne LC9B7 ; brif not +LC9BE decb ; are we at the end of the string? + beq LC99B ; brif so + lda ,u+ ; get character + cmpa #': ; drive number? + beq LC994 ; brif so + cmpx #DFLTYP ; is extension full? + beq LC978 ; brif so - bad fil ename + bsr LC9D0 ; put character in buffer + bra LC9BE ; process another character +LC9D0 sta ,x+ ; put character in buffer + beq LC978 ; brif NUL - don't allow it (first character NUL is deleted file) + cmpa #'. ; dot? + beq LC978 ; brif not - don't allow extension separator + cmpa #'/ ; ditto for slash + beq LC978 + inca ; is if 0xff? + beq LC978 ; brif so - first character 0xff means never used entry +LC9DF rts +; SAVE command +SAVE cmpa #'M ; is it SAVEM? + lbeq LCF68 ; brif so + bsr LCA33 ; parse file name + ldx ZERO ; set to BASIC program and binary + stx DFLTYP + jsr GETCCH ; is there something after the file name? + beq LCA12 ; brif not + jsr SYNCOMMA ; make sure we have a comma + ldb #'A ; only valid flag is "A" for ASCII + jsr LB26F + bne LC9DF ; brif more stuff follows - error + com DASCFL ; set to ASCII type + bsr LCA04 ; open sequential file for output + clra ; set Z to cause whole program to be listed + jmp LIST ; let LIST do the heavy lifting +LCA04 lda #'O ; output file type + skip2 +LCA07 lda #'I ; iput file type + ldb FCBACT ; get number of active FCBs + incb ; bump to system FCB + stb DEVNUM ; use the system FCB + jmp LC48D ; open file and initialize FCB +LCA12 bsr LCA04 ; open file for output + lda #0xff ; send basic file flag + jsr LCC24 + ldd VARTAB ; get end of program address + subd TXTTAB ; now we have length of program + jsr LCC24 ; output length MS byte + tfr b,a ; output length LS byte + jsr LCC24 + ldx TXTTAB ; point to start of program text +LCA27 lda ,x+ ; output byte from program + jsr LCC24 + cmpx VARTAB ; end of program? + bne LCA27 ; brif not + jmp LA42D ; close the file +LCA33 ldx #BASEXT ; point to BAS extension (for basic programs) + jmp LC938 ; parse file name +; MERGE command +MERGE clra ; run flag: 0 = don't run + ldb #0xff ; merge flag: 0xff = merge + bra LCA50 +; RUN handler +DVEC18 cmpa #'" ; do we have a file name? + lbne XVEC18 ; brif not + lda #2 ; RUN flag - run after loading + bra LCA4F ; load file +; LOAD command +LOAD cmpa #'M ; is it LOADM? + lbeq LCFC1 ; brif so + clra ; set not to RUN +LCA4F clrb ; set not to MERGE +LCA50 sta DRUNFL ; save RUN flag + stb DMRGFL ; save MERGE flag + bsr LCA33 ; parse file name + jsr GETCCH ; is there anything after the file name? + beq LCA6C ; brif not + jsr SYNCOMMA ; make sure comma + ldb #'R ; make sure the flag is "R" + jsr LB26F + jsr LA5C7 ; error if anything else + lda #3 ; set flags to RUN and not close files + sta DRUNFL +LCA6C bsr LCA07 ; open file for input + lda DASCFL ; is it ASCII? + beq LCA7E ; brif not + tst DMRGFL ; is it merge? + bne LCA7B ; brif so + jsr LAD19 ; do a "NEW" - erase existing program +LCA7B jmp LAC7C ; let immediate mode do the heavy lifting now +LCA7E lda DFLTYP ; get type + ora DMRGFL ; mix with merge flag + lbne LA616 ; if either of the above was nonzero, raise bad file mode + jsr LAD19 ; erase existing program + com DLODFL ; flag that we're loading a program + jsr LCDBC ; get initial character (discard it, should be 0xff) + jsr LCDBC ; get MSB of length + pshs a ; save it + jsr LCDBC ; get LSB of length + tfr a,b ; save length in D + puls a + addd TXTTAB ; add to start of program text + jsr LAC37 ; make sure it fits + ldx TXTTAB ; point to start of program +LCAA4 jsr LC5C4 ; get a character + ldb CINBFL ; EOF? + bne LCAAF ; brif so + sta ,x+ ; save character + bra LCAA4 ; process more +LCAAF clr DLODFL ; clear load flag - no errors + stx VARTAB ; set new end of program + ldb #3 ; make sure the last three bytes were 0 +LCAB6 lda ,-x ; do we have a 0? + bne LCABD ; brif not + decb ; done all three? + bne LCAB6 ; brif not +LCABD ldx VARTAB ; get end of program +LCABF stx VARTAB ; save new end of program + clr ,x+ ; blank a byte + decb ; done enough? + bpl LCABF ; brif not +LCAC6 jsr LA42D ; close the file + jsr LAD21 ; clear variables, reset stack, etc. + jsr XVEC18 ; initalize graphics stuff + jsr LACEF ; recalculate line pointers + asr DRUNFL ; are we supposed to close all files? + bcs LCADA ; brif not + jsr LA426 ; close all open files +LCADA asr DRUNFL ; are we supposed to run the program/ + lbcs LAD9E ; brif so - launch program + jmp LAC73 ; return to immediate mode +; EOF handler for main loop +DVEC13 tst DEVNUM ; is it disk file? + bgt LCAC6 ; brif so - run it if required + rts ; return to mainline otherwise +; Close all files handler +DVEC7 ldb FCBACT ; get number of reserved FCBs + incb ; include system FCB +LCAED pshs b ; save file count + stb DEVNUM ; set device to close + bsr LCB01 ; close it + puls b ; get back file count + decb ; move to next one + bne LCAED ; brif not done all disk files +LCAF8 rts +; Close one file handler +DVEC8 tst DEVNUM ; is it a disk file? + lble XVEC8 ; brif not + leas 2,s ; don't return to mainline +LCB01 jsr LC744 ; get FCB pointer + clr DEVNUM ; reset device number +LCB06 stx FCBTMP ; save FCB pointer + lda <<FCBTYP,x ; get file type + beq LCAF8 ; brif file isn't open - we don't have to do anything + pshs a ; save file type + clr <<FCBTYP,x ; mark file closed + ldb FCBDRV,x ; tell DSKCON which drive the file is on + stb DCDRV + cmpa #OUTFIL ; output file? + bne LCB31 ; brif not + ldb FCBLFT,x ; get number of characters in output buffer + lda #0x80 ; set pre-saved bit to indicate data already saved + ifeq DISKVER-1 + ora FCBCPT,x ; merge with full sector flag + endc + std FCBLST,x ; save number of bytes used in last sector + inc FCBSEC,x ; bump sector counter + ldb FCBCGR,x ; get current granule + jsr LC755 ; point to FAT + sta FAT1,x ; mark FAT data invalid + abx ; add granule offset to pointer + inc FATCON,x ; add one to sector count for last granule (skip control bytes) + ifeq DISKVER +LCB2E bra LCBC3 ; update FAT and directory, write out any final data + else +LCB2E jmp LCBC3 ; update FAT and directory, write out any final data + endc +LCB31 cmpa #RANFIL ; random file? + ifeq DISKVER + bne LCBC3 ; brif not + else + bne LCB2E ; brif not - update FAT and directory for input file + endc + ldd FCBRLN,x ; get record length + ldx FCBBUF,x ; get buffer pointer + leay d,x ; point to end of random file buffer + pshs y,x,b,a ; save pointers and length + ifeq DISKVER-1 + leay ,s ; save stack pointer + endc + ldu VARTAB ; get start of variables +LCB41 cmpu ARYTAB ; end of scalars? + beq LCB54 ; brif so + lda 1,u ; get second byte of variable name + leau 2,u ; move past variable name + bpl LCB4E ; brif numeric + bsr LCB76 ; adjust string variable if in random file buffer +LCB4E leau 5,u ; move to next variable entry + bra LCB41 ; process next variable entry +LCB52 puls u ; get address of next array +LCB54 cmpu ARYEND ; end of arrays? + ifeq DISKVER + beq LCB91 ; brif so + else + beq LCB93 ; brif so + endc + tfr u,d ; save array start + addd 2,u ; add length of array + pshs d ; save address of next array + lda 1,u ; is it string? + bpl LCB52 ; brif not - do next array + ldb 4,u ; get number of dimensions + aslb ; two bytes per dimension size + addb #5 ; 5 bytes constant per array header + clra ; zero extend + leau d,u ; point to start of array data +LCB6B cmpu ,s ; end of this array? + beq LCB52 ; brif so + bsr LCB76 ; adjust string variable if in random file buffer + leau 5,u ; move to next entry + bra LCB6B ; process next entry +LCB76 ldx 2,u ; get pointer to start of string + cmpx RNBFAD ; is it above top of random buffer area? + bhs LCB8B ; brif so + ifeq DISKVER + cmpx 4,s ; is it below this file's buffer area? + blo LCB8C ; brif so + cmpx 6,s ; is it above this file's buffer? + else + cmpx 2,y ; is it above start of this file's buffer area? + blo LCB8B ; brif not + cmpx 4,y ; is it below end of this file's buffer area? + endc + blo LCB8C ; brif so - we have to adjust it + tfr x,d ; save pointer in D + ifeq DISKVER + subd 2,s ; adjust pointer down by length of buffer area for this file + else + subd ,y ; adjust pointer down by length of buffer area for this file + endc + std 2,u ; save new start of string +LCB8B rts +LCB8C clr ,u ; mark string empty + clr 2,u ; NULL out string address + clr 3,u + rts + ifeq DISKVER +LCB91 puls a,b,x,u ; clean up stack + else +LCB93 ldb FCBACT ; get number of active files + incb ; include system FCB +LCB97 pshs b ; save files count + jsr LC749 ; point to FCB number in B + lda <<FCBTYP,x ; open as random file? + cmpa #RANFIL + bne LCBAD ; brif not + ldd FCBBUF,x ; get buffer pointer + cmpd 4,y ; is it above this file's buffer? + blo LCBAD ; brif not + subd ,y ; subtract out length for this file's buffer + std FCBBUF,x ; save new buffer area pointer +LCBAD puls b ; get files counter back + decb ; done all? + bne LCB97 ; brif not + puls a,b,x,u ; get back pointers and buffer length + endc +LCBB4 cmpu RNBFAD ; at top of buffers? + beq LCBC0 ; brif so + lda ,u+ ; copy a byte down + sta ,x+ + bra LCBB4 ; see if we're done yet +LCBC0 stx RNBFAD ; save new start of free buffer area +LCBC3 jsr LC755 ; point to proper FAT + dec <<FAT0,x ; remove one active file + tst FAT1,x ; new data in FAT image? + beq LCBCF ; brif not + jsr LC71E ; save modified FAT +LCBCF ldx FCBTMP ; get FCB pointer back + puls a ; get file type + cmpa #OUTFIL ; output? + beq LCBDF ; brif so + cmpa #RANFIL ; random? + bne LCB8B ; brif not + lda FCBFLG,x ; doing GET? + beq LCBE9 ; brif so +LCBDF jsr LC763 ; set up track and sector parameters + leau FCBCON,x ; point to data buffer + stu DCBPT + bsr LCC15 ; write out the sector data +LCBE9 lda FCBLST,x ; data pre-saved? + bpl LCB8B ; brif it has already been saved + ldb FCBDIR,x ; get directory number for this file + andb #7 ; 8 entries per sector + lda #DIRLEN ; calculate offset into directory sector + mul + ldu #DBUF0 ; point to global buffer + stu DCBPT ; set DSKCON buffer address + leay d,u ; Y points to directory entry now + ldb FCBDIR,x ; get directory entry number + lsrb ; divide by 8 (gives sector number) + lsrb + lsrb + addb #3 ; first directory sector is 3 + stb DSEC ; tell DSKCON + ldd #0x1102 ; set up to read track 17 + sta DCTRK + bsr LCC17 ; read directory sector + ldd FCBLST,x ; get number of bytes in last sector + anda #0x7f ; remove pre-saved flag + std DIRLST,y ; update directory entry +LCC15 ldb #3 ; write operation +LCC17 stb DCOPC ; tell DSKCON what to do + jmp LD6F2 ; go read or write sector +; Generic output handler +DVEC3 tst DEVNUM ; disk file? + lble XVEC3 ; brif not + leas 2,s ; don't return to mainline +LCC24 pshs x,b,a ; save registers + ldx #FCBV1-2 ; point to FCB list (-2 for 1-based file numbers) + ldb DEVNUM ; get device number + aslb ; two bytes per pointer + ldx b,x ; get FCB pointer + ldb ,x ; get file type + cmpb #INPFIL ; input? + beq LCC6A ; brif so - bail + cmpa #0x0d ; carriage return? + bne LCC3A ; brif so + clr FCBPOS,x ; reset print position if CR +LCC3A cmpa #0x20 ; control code? + blo LCC40 ; brif so + inc FCBPOS,x ; bump print position if printing character +LCC40 cmpb #RANFIL ; random file? + bne LCC5E ; brif not + ldd FCBPUT,x ; get put pointer + addd #1 ; bump it + cmpd FCBRLN,x ; did we overflow the record? + lbhi LCDCB ; brif so - raise error + std FCBPUT,x ; save updated pointer + ldx FCBBUF,x ; get buffer pointer + leax d,x ; add in offset + puls a ; get back output character + sta -1,x ; save in buffer (-1 because we already bumped pointer) + puls b,x,pc ; restore registers and return +LCC5E inc FCBLFT,x ; bump character count + ldb FCBLFT,x ; did we max out a sector? + beq LCC6C ; brif so + abx ; add offset into sector + sta FCBCON-1,x ; save output character in buffer, offset past control structure +LCC6A puls a,b,x,pc ; restore registers and return +LCC6C pshs u,y ; save registers + sta SECLEN+FCBCON-1,x ; save last character in buffer + ifeq DISKVER + jsr LC685 + endc + ldb FCBDRV,x ; tell DSKCON which drive + stb DCDRV + inc FCBSEC,x ; bump sector counter (in granule) + jsr LCBDF ; write file buffer to disk + leay ,x ; save FCB pointer + ldb FCBCGR,x ; get granule number + jsr LC755 ; get pointer to FAT + abx ; offset into granule data + leau FATCON,x ; now U points to granule data (offset past control structure) + lda FCBSEC,y ; get current sector offset + cmpa #9 ; end of granule? + blo LCC99 ; brif not + ifeq DISKVER-1 + dec FCBSEC,y ; decrement sector number and bump error flag in case error occurs + inc FCBCPT,y + else + clr FCBSEC,y + endc + jsr LC7BF ; allocate granule + ifeq DISKVER-1 + clr FCBSEC,y ; clear sector number + clr FCBCPT,y ; clear error flag - disk not full + endc + sta FCBCGR,y ; save new granule in FCB + skip2 +LCC99 ora #0xc0 ; mark granule as end of file + sta ,u ; save in granule map + ifeq DISKVER-1 + leax ,y ; get back FCB pointer + jsr LC685 ; bump record number + endc + jsr LC5A9 ; update FAT + puls y,u ; restore registers + puls a,b,x,pc ; restore registers and return +; DIR command +DIR jsr LD24F ; parse drive number + jsr LC79D ; fetch FAT for drive + jsr LB958 ; do a linefeed + ldd #0x1102 ; set up to read track 17 + sta DCTRK + stb DCOPC + ldb #3 ; start at sector 3 for the directory +LCCBB stb DSEC ; set sector to read + ldx #DBUF0 ; use the global sector buffer + stx DCBPT + jsr LD6F2 ; read directory sector +LCCC5 puls u ; do some stack games due to break check requirements + jsr LA549 + pshs u + lda ,x ; is this entry used? + beq LCD08 ; brif not + coma ; is it the start of never entries? + beq LCD17 ; brif so - we're done + pshs x ; save directory data pointer + ldb #8 ; print out 8 characters for the filename + jsr LB9A2 ; display file name + bsr LCD1B ; put a blank + ldb #3 ; show 3 characters in extension + jsr LB9A2 ; display extension + bsr LCD1B ; put a blank + ldb <<0,x ; get file type + cmpb #10 ; is it one digit? + bhs LCCEB ; brif so + bsr LCD1B ; put another blank +LCCEB clra ; zero extend type + jsr LBDCC ; show file type + bsr LCD1B ; another blank + ldx ,s ; get directory entry back + lda #'B ; set to binary + adda DIRASC,x ; add ASCII flag - will subtract 1 (to A) if ASCII + bsr LCD18 ; show character and a blank + ldb DIRGRN,x ; point to first granule in file + bsr LCD1E ; count granules + tfr a,b ; zero extend into D + clra + jsr LBDCC ; show granule count + jsr LB958 ; do a newline + puls x ; get back directory pointer +LCD08 leax DIRLEN,x ; move to next entry + cmpx #DBUF0+SECLEN ; end of sector? + blo LCCC5 ; brif not + ldb DSEC ; get sector number + incb ; move to next one + cmpb #SECMAX ; end of track? + bls LCCBB ; brif not +LCD17 rts +LCD18 jsr PUTCHR ; display character +LCD1B jmp LB9AC ; display a space +; Count granule chain starting at granule number in B +LCD1E jsr LC755 ; get FAT pointer + leau FATCON,x ; point past control structure + clra ; reset count to 0 +LCD24 inca ; bump granule count + cmpa #GRANMX ; at maximum size of disk? + lbhi LC653 ; do FS error if so + leax ,u ; point to base FAT data + abx ; offset to granule number + ldb ,x ; get next granule pointer + cmpb #0xc0 ; end of file marker? + blo LCD24 ; brif not + rts +; INPUT handler; this whole mess is requried because the disk data format varies from that used +; by tape files. +DVEC10 tst DEVNUM ; are we reading from a disk file? + ble LCD97 ; brif not + ldx #LB069 ; change return address to skip ? prompt + stx ,s + ldx #LINBUF+1 ; point to input buffer + ldb #', ; set item separator to , + stb CHARAC + lda VALTYP ; get type wanted + bne LCD4B ; brif string + ldb #0x20 ; space is the numeric delimiter +LCD4B bsr LCDBC ; fetch input character + cmpa #0x20 ; space? + beq LCD4B ; brif so + cmpa #'" ; quote? + bne LCD5F ; brif not + cmpb #', ; delim is ,? + bne LCD5F ; brif not - numeric + tfr a,b ; save quote as search character + stb CHARAC + bra LCD81 ; save quote as first item in buffer +LCD5F cmpb #'" ; string value? + beq LCD74 ; brif so + cmpa #0x0d ; end of line? + bne LCD74 ; brif not + cmpx #LINBUF+1 ; at start of buffer? + beq LCDB0 ; brif so - check for LF + lda -1,x ; get back input character + cmpa #0x0a ; was it LF? + bne LCDB0 ; brif not + lda #0x0d ; restore CR as input character +LCD74 tsta ; NUL? + beq LCD8E ; brif so - ignore it + cmpa CHARAC ; hit a delimiter? + beq LCD98 ; brif so + pshs b ; does it match the other delimiter? + cmpa ,s+ + beq LCD98 ; brif so +LCD81 sta ,x+ ; save character in buffer + cmpx #LINBUF+LBUFMX ; end of buffer? + bne LCD8E ; brif not + bsr LCDD0 ; fetch character + bne LCD92 ; brif buffer empty + bra LCDAC ; check for CR/CRLF +LCD8E bsr LCDD0 ; get input character + beq LCD5F ; brif we have something +LCD92 clr ,x ; put NUL at end of buffer + ldx #LINBUF ; point to input buffer +LCD97 rts +LCD98 cmpa #'" ; quote? + beq LCDA0 ; brif so + cmpa #0x20 ; space? + bne LCD92 ; brif not +LCDA0 bsr LCDD0 ; get character + bne LCD92 ; brif end + cmpa #0x20 ; space? + beq LCDA0 ; brif so - skip it + cmpa #', ; item separator? + beq LCD92 ; brif so - done +LCDAC cmpa #0x0d ; carriage return? + bne LCDB8 ; brif not +LCDB0 bsr LCDD0 ; fetch character + bne LCD92 ; brif end + cmpa #0x0a ; line feed? + beq LCD92 ; brif so - skip it +LCDB8 bsr LCDD6 ; unget character + bra LCD92 ; handle exit +LCDBC bsr LCDD0 ; fetch character + beq LCDD5 ; brif not end of file + jsr LC744 ; point to FCB + ldb <<FCBTYP,x ; get file type + cmpb #RANFIL ; random file? + lbne LC352 ; brif not - do input past end of file +LCDCB ldb #2*37 ; code for input past end of record + jmp LAC46 ; raise error +LCDD0 jsr LA176 ; read character + tst CINBFL ; set Z if not EOF +LCDD5 rts +LCDD6 pshs x,b ; save registers + jsr LC744 ; point to FCB + ldb <<FCBTYP,x ; random file? + cmpb #RANFIL + bne LCDEC ; brif not + ldd FCBGET,x ; get input pointer + subd #1 ; move it back (no error check!) + std FCBGET,x ; save new pointer + puls b,x,pc ; restore registers and return +LCDEC sta FCBCDT,x ; save unget character + com FCBCFL,x ; flag that we have an ungot character + puls b,x,pc ; restore registers and return +; CVN function +CVN jsr LB654 ; evaluate argument string + cmpb #5 ; is it at least 5 bytes (packed FP number)? + lblo LB44A ; brif not - raise error + clr VALTYP ; result is numeric + jmp LBC14 ; unpack string into return value +; MKN$ function +MKN jsr LB143 ; make sure we have a number + ldb #5 ; string will be 5 bytes long + jsr LB50F ; reserve space for it + jsr LBC35 ; pack argument into the string + jmp LB69B ; return the newly created string +; LOC function +LOC bsr LCE19 ; get pointer to correct FCB + ldd FCBREC,x ; get record number (random file) or sector counter + ifeq DISKVER +LCE14 jmp GIVABF ; return result as integer + else +LCE14 std FPA0+2 ; return result as an unsigned integer + jmp L880E + endc +; Evaluate device number, set print parameters, and point to FCB +LCE19 lda DEVNUM ; save current device number + pshs a + jsr LB143 ; make sure we have a number + jsr LA5AE ; check device and set print params + tst DEVNUM ; is it a disk file? + lble LB44A ; brif not + jsr LC744 ; point to FCB + puls a ; restore original device number + sta DEVNUM + tst <<FCBTYP,x ; is file open? + lbeq LA3FB ; brif not, do NO error + rts +; LOF function +LOF bsr LCE19 ; point to FCB + lda FCBDRV,x ; tell DSKCON the drive number + sta DCDRV + ldb FCBFGR,x ; get first granule of file + pshs x ; save FCB pointer + jsr LCD1E ; count granules in file + deca ; subtract out last granule + andb #0x3f ; get number of sectors in last granule + pshs b ; save it + tfr a,b ; zero extend granule number to D + clra + jsr LC779 ; multiply by 9 for total sector count + addb ,s+ ; add in sectors in last granule + adca #0 + puls x ; get back FCB pointer + pshs a ; temp save + lda <<FCBTYP,x ; is it random file? + cmpa #RANFIL + puls a ; restore register + bne LCE14 ; brif not random file - return number of sectors + pshs x ; save FCB pointer + subd ZERO ; "tstd" + beq LCE68 ; brif file is empty + subd #1 ; don't count last sector as fully used +LCE68 bsr LCE14 ; put D into FPA0 + ldb FP0EXP ; is it 0? + beq LCE72 ; brif so + addb #8 ; multiply by 256 + stb FP0EXP +LCE72 jsr LBC5F ; save result in FPA1 + ldx ,s ; get back FCB pointer + ldd FCBLST,x ; get number of bytes in last sector + anda #0x7f ; clear out pre-save flag + bsr LCE14 ; stuff that number in FPA0 + clr RESSGN ; result will be positive + lda FP1EXP ; get exponents + ldb FP0EXP + jsr LB9C5 ; add number of bytes in last sector + jsr LBC5F ; save total in FPA1 + puls x ; get FCB + ldd FCBRLN,x ; get record length + bsr LCE14 ; turn it into a FP number + clr RESSGN ; make result positive + lda FP1EXP ; get exponents + ldb FP0EXP + jsr LBB91 ; divide total by record size + jmp INT ; return the result as an integer +; FREE function +FREE jsr LB143 ; make sure we have a number + jsr LB70E ; get value in B + cmpb #3 ; valid drive? + lbhi LA61F ; brif not + stb DCDRV ; set drive + jsr LC79D ; read FAT + jsr LC755 ; point to FAT + leax FATCON,x ; point to actual granule data + clr ,-s ; initialize free count + ldb #GRANMX ; total granules to check +LCEB6 lda ,x+ ; get granule data + coma ; is it free? + bne LCEBD ; brif not + inc ,s ; bump free count +LCEBD decb ; checked them all? + bne LCEB6 ; brif not + puls b ; get free count + jmp LB4F3 ; return free count +; DRIVE command +DRIVE jsr EVALEXPB ; evaluate drive number to B + cmpb #3 ; valid? + lbhi LA61F ; brif not + stb DEFDRV ; set default drive + rts +; Expression evaluation handler; this is needed so we can move strings into string space +; if regular assignment to a FIELDed string is done. There really isn't a better place to +; intercept this, unfortunately. +DVEC15 lda 4,s ; is it end of operation? + bne LCEE9 ; brif not + ldx 5,s ; are we comming from LET? + cmpx #LAF9A + bne LCEE9 ; brif not + ldx 2,s + cmpx #LB166 + bne LCEE9 ; and brif not again + ldx #LCEEC ; install intercept for LET + stx 5,s +LCEE9 jmp XVEC15 ; let ECB do its thing +; LET modifier +LCEEC puls a ; get variable type + rora ; set C if string + jsr LB148 ; make sure things match + lbeq LBC33 ; brif numeric - we can go back to mainline + ldx FPA0+2 ; get string descriptor + ldd 2,x ; get data pointer + cmpd #DFLBUF ; is it below random buffers? + blo LCF07 ; brif so + subd FCBADR ; is it within the random buffers? + lblo LAFB1 ; brif so - move string to string space +LCF07 jmp LAFA4 ; return to mainline code +; ECB interpretation handler intercept; the PMODE intercept fixes a stupid usage of a constant 6 for the +; start of graphics memory in PMODE. The DLOAD intercept fixes the problem where DLOADM couldn't be +; detected due to A being clobbered before it was checked. Both of those bugs were fixed in ECB 1.1. +DXCVEC cmpa #0xca ; DLOAD? + beq LCF2A ; brif so + cmpa #0xc8 ; PMODE? + lbne L813C ; brif not - return to ECB's handler + jsr GETNCH ; get input character + cmpa #', ; no PMODE argument? + lbeq L9650 ; brif not - return to mainline + jsr EVALEXPB ; evaluate PMODE number + cmpb #4 ; valid? + lbhi LB44A ; brif not + lda GRPRAM ; fetch start of grahpics memory (work around usage of constant 6 in ECB 1.0) + jmp L962E ; return to mainline PMODE +LCF2A jsr LA429 ; close files + jsr GETNCH ; fetch input character + jmp L8C1B ; return to mainlnie +; ECB function interpetation handler intercept; this is needed to patch into the POS() function. +DXIVEC cmpb #(0x9a-0x80)*2 ; is it POS? + lbne L8168 ; brif not - return to ECB mainline + jsr LB262 ; evaluate argument + lda DEVNUM ; get device number + pshs a ; save it + jsr LA5AE ; evaluate device number + jsr LA406 ; make sure it's open + tst DEVNUM ; disk file? + ble LCF5C ; brif not + jsr LC744 ; point to FCB + ldb <<FCBTYP,x ; get file type + cmpb #RANFIL ; random file? + bne LCF5C ; brif not + puls a ; get back saved device number + sta DEVNUM + ldd FCBPUT,x ; get "put" position + jmp GIVABF ; return that as the position +LCF5C jsr LA35F ; set print parameters + puls a ; restore device number + sta DEVNUM + ldb DEVPOS ; get print position + jmp LB4F3 ; return B as unsigned +; SAVEM command (comes from SAVE command) +LCF68 jsr GETNCH ; eat the "M" + bsr LCFBB ; parse filename + jsr L836C ; evaluate start address + jsr L836C ; evaluate end address + cmpx 2,s ; is start > end? + lblo LB44A ; brif so - throw an error + jsr L836C ; evaluate execution address + jsr LA5C7 ; make sure there's nothing more + ldd #0x200 ; file type 2 (M/L) and binary + std DFLTYP + jsr LCA04 ; open file for output + clra ; write preamble header + bsr LCFB5 + ldd 2,s ; get end address + subd 4,s ; subtract start - gets length + addd #1 ; length is inclusive + tfr d,y ; set data counter + bsr LCFB3 ; output the length of the block + ldd 4,s ; output the load address + bsr LCFB3 + ldx 4,s ; point to start of block +LCF9B lda ,x+ ; grab output byte + jsr LCC24 ; write it + leay -1,y ; done yet? + bne LCF9B ; brif not + lda #0xff ; write header for postamble + bsr LCFB5 + clra ; write dummy 16 bits (would be block length) + clrb + bsr LCFB3 + puls d,x,y ; get back execution address and clean stack + bsr LCFB3 ; write out execution address + jmp LA42D ; close file +LCFB3 bsr LCFB5 ; write MSB of word; fall through for LSB +LCFB5 jsr LCC24 ; write byte out + exg a,b ; swap bytes in word + rts +LCFBB ldx #BINEXT ; set default extension to "BIN" + jmp LC938 ; parse filename +; LOADM command (comes from LOAD command) +LCFC1 jsr GETNCH ; eat the "M" + bsr LCFBB ; parse filename + jsr LCA07 ; open file for input + ldd DFLTYP ; get type of file + subd #0x200 ; is it M/L and binary? + lbne LA616 ; bad file mode if not + ldx ZERO ; set default offset value + jsr GETCCH ; is there a load offset? + beq LCFDE ; brif not + jsr SYNCOMMA ; insist on a comma + jsr LB73D ; evaluate offset to X +LCFDE stx VD3 ; save offset + jsr LA5C7 ; insist on end of statement +LCFE3 jsr LCDBC ; read "amble" header + pshs a ; save "amble" type + bsr LD013 ; read block length + tfr d,y ; save it (in counter) + bsr LD013 ; read block address + addd VD3 ; add load offset + std EXECJP ; set execution address + tfr d,x ; put it also in a pointer + lda ,s+ ; set flags on "amble" type + lbne LA42D ; brif postamble - stop reading +LCFFA jsr LC5C4 ; read a byte + ldb CINBFL ; EOF? + beq LD004 ; brif not + jmp LC352 ; raise "IE" error +LD004 sta ,x ; save byte in memory + cmpa ,x+ ; does the byte match? + beq LD00D ; brif so + jmp LD709 ; bad store - throw I/O error +LD00D leay -1,y ; done whole block? + bne LCFFA ; brif not + bra LCFE3 ; process another "amble" +LD013 bsr LD015 ; read MSB then fall through for LSB +LD015 jsr LCDBC ; read a byte from the file + exg a,b ; swap bytes in word + rts +; RENAME command +RENAME ldx CHARAD ; get input pointer + pshs x ; save it + bsr LD056 ; evaluate source file name + lda DCDRV ; save drive for first file + pshs a + bsr LD051 ; evaluate TO and destination file + puls a ; get back original drive number + cmpa DCDRV ; does it match? + lbne LB44A ; brif not - we can't rename across drives + bsr LD059 ; make sure new file does not already exist + puls x ; get back input pointer + stx CHARAD + bsr LD056 ; re-evaluate source file + jsr LC68C ; find the source file + jsr LC6E5 ; throw error if not found + bsr LD051 ; evaluate destination file name + ldx #DNAMBF ; point to destinatoin file name + ldu V974 ; point to directory entry + ldb #11 ; 8 characters file name and 3 characters extension + jsr LA59A ; replace file name + ldb #3 ; operation code for write + stb DCOPC + jmp LD6F2 ; write updated directory sector +LD051 ldb #0xa5 ; insist on "TO" + jsr LB26F +LD056 jmp LC935 ; evaluate file name with default blank extension +LD059 jsr LC68C ; find file + ldb #33*2 ; code for already exists + tst V973 ; does it exist? + lbne LAC46 ; brif so - raise error + rts +; WRITE command +WRITE lbeq LB958 ; do CR if end of statement + bsr LD06F ; write an item list + clr DEVNUM ; reset device to screen +LD06E rts +LD06F cmpa #'# ; device number? + bne LD082 ; brif not + jsr LA5A5 ; evaluate device number + jsr LA406 ; check for output + jsr GETCCH ; end of statement? + lbeq LB958 ; brif so - do newline +LD07F jsr SYNCOMMA ; need a comma after device +LD082 jsr LB156 ; evaluate expression + lda VALTYP ; number or string? + bne LD0A7 ; brif string + jsr LBDD9 ; convert number to strng + jsr LB516 ; stash it as the current value + jsr LB99F ; output the string +LD092 jsr GETCCH ; is there more? + lbeq LB958 ; brif not - do newline + lda #', ; comma for non-tape separator + jsr LA35F ; set print parameters + tst PRTDEV ; tape? + beq LD0A3 ; brif not + lda #0x0d ; carriage return for tape separator +LD0A3 bsr LD0B9 ; send separator + bra LD07F ; process another item +LD0A7 bsr LD0B0 ; print leading string delimiter + jsr LB99F ; print string + bsr LD0B0 ; print ending string delimiter + bra LD092 ; handle separator or next item +LD0B0 jsr LA35F ; set print parameters + tst PRTDEV ; tape? + bne LD06E ; brif so + lda #'" ; string delimiter +LD0B9 jmp PUTCHR ; send character out +; FIELD command +FIELD jsr LC82E ; evaluate device number and make sure it's a random file + clra ; clear total field length counter + clrb + pshs x,b,a ; save field length and FCB pointer +LD0C3 jsr GETCCH ; are we at the end of the statement? + bne LD0C9 ; brif not + puls a,b,x,pc ; clean up stack and return +LD0C9 jsr LB738 ; evaluate comma and expression + pshs x,b ; save field length (B) and make a hole for a temp + clra ; zero extend length + addd 3,s ; add in current accumulated size + bcs LD0DA ; brif we overflowed + ldx 5,s ; point to FCB + cmpd FCBRLN,x ; have we overflowed the record? + bls LD0DF ; brif not +LD0DA ldb #34*2 ; code for field overflow + jmp LAC46 ; raise error +LD0DF ldu 3,s ; get old accumulated length + std 3,s ; save new accumulated length + ldd FCBBUF,x ; get start of random buffer + leau d,u ; now U is the start of the field in the buffer + stu 1,s ; save it so we can set string descriptor + ldb #0xff ; insist on two byte "AS" token + jsr LB26F + ldb #0xa7 + jsr LB26F + jsr LB357 ; evaluate variable + jsr LB146 ; error if it's a number + puls b,u ; get back field length and buffer address + stb ,x ; put those in the string descriptor + stu 2,x + bra LD0C3 ; look for another entry +; RSET command +RSET skip1lda ; set nonzero for right justify and fall through +; LSET command +LSET clra ; set zero to flag left justify + pshs a ; save justification type + jsr LB357 ; evaluate variable + jsr LB146 ; make sure it's a string + pshs x ; save descriptor address + ldx 2,x ; get address of string data + cmpx #DFLBUF ; is it below random buffer area? + blo LD119 ; brif below - throw error + cmpx FCBADR ; is it above the random buffer area? + blo LD11E ; brif not - it's good +LD119 ldb #2*35 ; code for "set to non-fielded string" + jmp LAC46 ; raise error +LD11E ldb #0xb3 ; insist on = + jsr LB26F + jsr L8748 ; evaluate string expression; return details + puls y ; get back destination descriptor pointer + lda ,y ; get length of field string + beq LD15A ; brif empty destination + pshs b ; save length of new string + ldb #0x20 ; pad characteris space + ldu 2,y ; point to destination string +LD132 stb ,u+ ; blank out string + deca ; done yet? + bne LD132 ; brif not + ldb ,s+ ; get length of data string + beq LD15A ; brif that one is NULL + cmpb ,y ; is data string smaller than destination? + blo LD143 ; brif not + ldb ,y ; get length of destination string as the copy length + clr ,s ; we'll do left justify if string is longer +LD143 ldu 2,y ; get address of the destination + tst ,s+ ; left or right justify? + beq LD157 ; brif left set + pshs b ; save number of bytes to move into field string + clra ; get negation of that in D (do -DLEN+FLEN) + negb + sbca #0 + addb ,y ; then add string length of destination to it + adca #0 + leau d,u ; now U points to destination offset + puls b ; get back destination size +LD157 jmp LA59A ; copy data and return +LD15A puls a,pc ; clean up stack and return +; FILES command +FILES jsr L95AC ; reset video display + ldd FCBADR ; get current size of buffer space + subd #DFLBUF + pshs d ; save it as the default size + ldb FCBACT ; get number of available disk files + pshs b ; save it as the default number + jsr GETCCH ; get input character + cmpa #', ; is numer of files specified? + beq LD181 ; brif not + jsr EVALEXPB ; evaluate the number of files wanted + cmpb #15 ; we only allow 15 + lbhi LB44A ; raise error if too many + stb ,s ; save number of FCBs to allocate + jsr GETCCH ; see what's after the number + beq LD189 ; brif no buffer size specified +LD181 jsr SYNCOMMA ; insist on a comma + jsr LB3E6 ; evaluate buffer size + ifeq DISKVER + addd #1 + endc + std 1,s ; save buffer size +LD189 jsr DVEC7 ; close all disk files + ldb ,s ; get number of files + pshs b ; initialize the file number count + ldd #DFLBUF ; point to start of random buffers + addd 2,s ; add in size requested for buffer space + bcs LD208 ; raise error if we carry + std 2,s ; save start of FCBs +LD199 addd #FCBLEN ; add size of one FCB + bcs LD208 ; brif we overflowed + dec ,s ; added on for all files? + bpl LD199 ; brif not yet (BPL so we set up the system one as well) + tstb ; are we at an even page boundary? + ifeq DISKVER + beq LD1AF ; brif so + else + beq LD1A8 ; brif so + endc + inca ; round up + beq LD208 ; brif we overflowed + ifeq DISKVER-1 +LD1A8 bita #1 ; on an even 512 byte boundary? + beq LD1AF ; brif so + inca ; round up + beq LD208 ; brif we overflowed + endc +LD1AF sta ,s ; save MSB of graphics memory + ldd VARTAB ; get end of program + suba GRPRAM ; subtract out start of graphics (D is now size of program and graphics) + adda ,s ; add in the new start of graphics + bcs LD208 ; brif overflow + tfr d,x ; save new top of program + inca ; add some extra room for the stack + beq LD208 ; brif overflow + cmpd FRETOP ; does it fit in memory? + bhs LD208 ; brif not + deca ; restore actual top of program + subd VARTAB ; get difference compared to the original top of program + addd TXTTAB ; add that to the program start + tfr d,y ; now Y is the new start of the program + lda ,s ; get back start of graphics memory + suba GRPRAM ; this gives difference between old graphics start and new grahpics start + tfr a,b ; we need this twice + adda BEGGRP ; set new start of active page + sta BEGGRP + addb ENDGRP ; set new end of active page + stb ENDGRP + puls a,b,u ; get back graphics start, number of files, and start of buffers + sta GRPRAM ; set graphics memory start + stb FCBACT ; set number of active FCBs + stu FCBADR ; set start of FCBs + ifeq DISKVER-1 + lda CURLIN ; in immediate mode? + inca + beq LD1EF ; brif so + tfr y,d ; calculate how much the program is moving + subd TXTTAB + addd CHARAD ; adjust input pointer for the change + std CHARAD + endc +LD1EF ldu VARTAB ; get old end of program + stx VARTAB ; save new end of program + cmpu VARTAB ; which way did it move? + bhi LD20B ; brif it moved up +LD1F8 lda ,-u ; move a byte down + sta ,-x + cmpu TXTTAB ; at start? + bne LD1F8 ; brif not + sty TXTTAB ; set new start of program + clr -1,y ; make sure there's a NUL before the program + bra LD21B ; clean up +LD208 jmp LAC44 ; raise OM error +LD20B ldu TXTTAB ; get old start of program + sty TXTTAB ; save new start of program + clr -1,y ; make sure there's a NUL before the program +LD212 lda ,u+ ; move a byte up + sta ,y+ + cmpy VARTAB ; at end yet? + bne LD212 ; brif not +LD21B ldu #FCBV1 ; point to FCB pointers + ldx FCBADR ; point to start of FCBs + clrb ; file counter +LD222 stx ,u++ ; set FCB pointer + clr <<FCBTYP,x ; mark FCB as closed + leax FCBLEN,x ; point to next FCB + incb ; bump file counter + cmpb FCBACT ; do we have enough of them yet? + bls LD222 ; brif not (BLS so we include system FCB) + jmp L96CB ; fix up line pointers, etc. +; UNLOAD command +UNLOAD bsr LD24F ; get drive number + clrb ; clear file counter +LD236 incb ; bump file counter + jsr LC749 ; point to FCB + beq LD249 ; brif file not open + lda FCBDRV,x ; is it on the right drive? + cmpa DCDRV + bne LD249 ; brif not + pshs b ; save file counter + jsr LCB06 ; close the file + puls b ; restore file counter +LD249 cmpb FCBACT ; done all files? + bls LD236 ; brif not (includes system FCB) + rts +; Parse drive number; use default if none given +LD24F ldb DEFDRV ; set default drive + jsr GETCCH ; is there something there? + beq LD25F ; brif not +LD256 jsr EVALEXPB ; evaluate drive number + cmpb #3 ; valid? + lbhi LA61F ; brif not +LD25F stb DCDRV ; set drive number + rts +; BACKUP command +BACKUP lbeq LA61F ; raise error if no drive numbers + jsr L95AC ; reset display + jsr LD256 ; get source drive number + stb DBUF0+255 ; save it (we're going to put our stack in DBUF0) + jsr GETCCH ; is there something else? + beq LD27B ; brif not + ldb #0xa5 ; insist on TO + jsr LB26F + jsr LD256 ; fetch destination drive +LD27B lds #DBUF0+255 ; put the stack somewhere safe (source drive number already there) + pshs b ; save destination drive number + jsr LA5C7 ; bail of there's more + jsr DVEC7 ; close files + clr ,-s ; initialize track counter + ldx #DFLBUF-1 ; point to start of the heap +LD28C inc ,s ; bump track counter + leax SECMAX*SECLEN,x ; add a whole track to the count + cmpx MEMSIZ ; does it fit in memory? + bls LD28C ; brif so + dec ,s ; decrement track counter + lbeq LAC44 ; error if less than one track memory available + lda #TRKMAX ; get maximum number of tracks + clrb ; set tracks copied to 0 + pshs a,b ; save track counters + com DRESFL ; force a "reset" of the disk system +LD2A4 clrb ; initialize write counter +LD2A5 incb ; add one to track counter + dec ,s ; whole disk done? + beq LD2AE ; brif not + cmpb 2,s ; will it fit in memory? + bne LD2A5 ; brif so +LD2AE stb TMPLOC ; save number of tracks to copy + ldb 4,s ; get source drive number + bsr LD2FC ; read TMPLOC tracks + lda #0xff ; set source/dest flag to dest + jsr LD322 ; show prompt if needed + ldb 3,s ; get destination drive + bsr LD2FF ; write TMPLOC tracks + tst ,s ; is there anything left? + beq LD2CD ; brif not - we're done + clra ; set source/desetination to source + jsr LD322 ; show prompt + ldb 1,s ; get tracks written + addb TMPLOC ; account for the ones we just wrote + stb 1,s ; save new written counter + bra LD2A4 ; go copy some more tracks +LD2CD bsr LD2D2 ; check for re-init + jmp LAC73 ; return to immediate mode +LD2D2 puls u ; get return address (we might be resetting the stack) + lda DRESFL ; reset desired? + beq LD2EF ; brif not + ldx #FCBV1 ; point to FCB addresses + clra ; set file counter to 0 +LD2DD clr [,x++] ; mark FCB as closed + inca ; bump file counter + cmpa FCBACT ; end of allocated FCBs? + bls LD2DD ; brif not + ldx TXTTAB ; get start of program + clr -1,x ; make sure there's a NUL there + jsr LAD19 ; do a "NEW" + clr DRESFL ; mark reset as not needed +LD2EF lda DLODFL ; were we loading something? + beq LD2FA ; brif not + clr DLODFL ; clear out the loading state + jsr LAD19 ; empty out the program +LD2FA jmp ,u ; return to caller +LD2FC lda #2 ; opcode for read + skip2 +LD2FF lda #3 ; opcode for write + std DCOPC ; save operation and drive number + lda 3,s ; get number of the first track to write + sta DCTRK ; tell DSKCON + ldx #DFLBUF ; put track buffer at the start of the heap + stx DCBPT + lda TMPLOC ; get track counter +LD30E ldb #1 ; start at sector 1 +LD310 stb DSEC ; set sector + jsr LD6F2 ; read or write a sector + inc DCBPT ; bump buffer pointer + incb ; bump sector number + cmpb #SECMAX ; end of track? + bls LD310 ; brif not + inc DCTRK ; bump track + deca ; done all the tracks? + bne LD30E ; brif not + rts +LD322 ldb 5,s ; get destination drive number + cmpb 6,s ; compare to source +LD326 bne LD35E ; brif no prompt needed + clr RDYTMR ; reset drive motor + clr DSKREG + clr DRGRAM + pshs a ; save source/dest flag + jsr LA928 ; clear screen + ldx #LD35F ; point to "source" + ldb #13 ; 13 bytes + lda ,s+ ; set flags on source/dest flag + beq LD344 ; brif source + ldx #LD36C ; point to "dest" + ldb #18 ; 18 bytes +LD344 jsr LB9A2 ; display message + ldx #LD37E ; point to remainder of message + ldb #27 ; 27 bytes + jsr LB9A2 ; display it + ldd #0x6405 ; set up SOUND parameters + sta SNDTON + jsr LA951 ; do a beep +LD357 jsr LA171 ; read generic input (shows cursor) + cmpa #0x0d ; carriage return? + bne LD357 ; bri fnot +LD35E rts +LD35F fcc 'INSERT SOURCE' +LD36C fcc 'INSERT DESTINATION' +LD37E fcc ' DISKETTE AND' + fcb 0x0d + fcc "PRESS 'ENTER'" +; Save file name and extension on stack, and also the current drive number +LD399 puls y ; get return address + ldb #11 ; 11 characters for both name and extension + ldx #DNAMBF+11 ; point to end of buffer +LD3A0 lda ,-x ; fetch a file name character + pshs a ; stuff it on the stack + decb ; done yet? + bne LD3A0 ; brif not + lda DCDRV ; save drive number + pshs a + jmp ,y ; return to caller +; Copy drive, filename, and extension from X to state +LD3AD lda ,x+ ; set drive number + sta DCDRV + ldb #11 ; 11 characters in file name and extension + ldu #DNAMBF ; point to disk file name buffer + jmp LA59A ; copy the file name +; COPY command +; NOTE: an error during COPY will cause the system to hang due to the FCB's buffer pointer +; being moved out of normal buffer space. +COPY jsr LC935 ; get source file name + bsr LD399 ; save it on the stack + clr ,-s ; set flag for "single disk" copy + jsr GETCCH ; is there a destination? + beq LD3CE ; brif not - single disk (swapping) + com ,s ; set to "two parameter" copy + ldb #0xa5 ; insist on TO + jsr LB26F + jsr LC935 ; parse the destination file name +LD3CE bsr LD399 ; save destination file name + jsr LA5C7 ; bail if more stuff + jsr DVEC7 ; close everything + clr ,-s ; clear sector counter + ifeq DISKVER + leax -100,s ; leave a buffer below the stack + else + leax -SECLEN,s ; point one sector below the stack + endc +LD3DC inc ,s ; bump sector counter + leax -SECLEN,x ; move back a sector + cmpx ARYEND ; did we hit the top of variables? + bhs LD3DC ; brif not + dec ,s ; decrement off the last one that didn't fit + lbeq LAC44 ; brif not at least one sector free memory + leax 14,s ; set up for source file name/drive + bsr LD3AD + jsr LC68C ; find file + jsr LC6E5 ; error if not found + ldx V974 ; get directory data pointer + ldu DIRLST,x ; get file type and last sector data + ldx DIRTYP,x + pshs u,x ; save them + jsr LC79D ; read FAT data + ldb V976 ; get first granule in file + jsr LCD1E ; count granules in chain + pshs a ; save number of granules in file + deca ; subtract off last granule (may be partial) + andb #0x3f ; get number of sectors in last granule + pshs b ; save sectors in last granule + tfr a,b ; zero extend to granule count to D + clra + jsr LC779 ; get number of sectors in complete granules + addb ,s ; add in partial sector count + adca #0 + ldx #1 ; initialize record counter to 1 + pshs x,b,a ; save record counter and sector counter +LD41E clrb ; set sector counter to 0 + ldx ,s ; get number of sectors remaining in the file + beq LD42C ; brif none left +LD423 incb ; add a sector to counter + leax -1,x ; at bottom of file? + beq LD42C ; brif so + cmpb 10,s ; at maximum memory space? + bne LD423 ; brif not +LD42C stx ,s ; save number of sectors that will be left after this iteration + stb 4,s ; save number of sectors to be copied this time + bsr LD482 ; get sectors to buffer + lda #0xff ; show swap message for dest + bsr LD476 + tst 5,s ; do we need to test for enough free space? + beq LD45F ; brif not + leax 11,s ; retrieve destination file parameters + jsr LD3AD + jsr LD059 ; find the file, AE error if it exists + jsr LC79D ; get FAT data + jsr LC755 ; point to FAT + leax FATCON,x ; point to granuledata + lda 5,s ; get number of granules in file + ldb #GRANMX ; maximum granules to check +LD44E com ,x ; is granule free? + bne LD455 ; brif not + deca ; found enough? + beq LD45D ; brif not +LD455 com ,x+ ; restore FAT data + decb ; run through whole fat? + bne LD44E ; brif not + jmp LC7F8 ; do "disk full" +LD45D com ,x ; restore FAT data +LD45F bsr LD47C ; put data from memory to destination file + ldx ,s ; get number of sectors left + beq LD472 ; brif none - we're done + ldd 2,s ; get current recordcounter + addb 4,s ; add in number of sectors + adca #0 + std 2,s ; save new record counter + clra ; show source message if needed + bsr LD476 + bra LD41E ; copy some more stuff +LD472 leas 36,s ; clean up stack + rts +LD476 tst 25,s ; doing a "single disk" copy? + jmp LD326 ; show message if needed +; put or get data for copy +LD47C lda #0xff ; put flag + leax 13,s ; point to destination file + bra LD486 ; go do the write +LD482 clra ; get flag + leax 26,s ; point to source file +LD486 sta VD8 ; save get/put flag + jsr LD3AD ; fetch file parameters from stack + ldx 8,s ; get file type and ASCII flag + stx DFLTYP ; save it + ldx #SECLEN ; set record length to one sector + stx DFFLEN + lda #'R ; set type to "random" + ldb FCBACT ; point to system FCB + incb + jsr LC48D + ldx FCBTMP ; get FCB pointer + ldd #SECLEN ; set number of bytes in last sector to one sector + std FCBLST,x + ldb 6,s ; get number of sectors to read/write + beq LD4D4 ; brif none + ldb VD8 ; get or put? + andb 7,s ; is it first time on put? + beq LD4BA ; brif not + ldd 2,s ; get number of sectors remaining + addb 6,s ; add to number copied this time + adca #0 + jsr LC2E6 ; put the last record in the file (this allocates the file) +LD4BA ldx FCBTMP ; point to FCB + ldu 4,s ; get current record number + stu FCBREC,x ; save in FCB + ldb 6,s ; get number of sectors to move + ldu ARYEND ; point to start of free memory +LD4C4 pshs u,b ; save buffer pointer and counter + ldx FCBTMP ; fetch FCB pointer + stu FCBBUF,x ; set buffer to free memory (will cause hang on error) + jsr LC2EA ; do get or put + inc 1,s ; bump buffer pointer + puls b,u ; get back buffer pointer and sector count + decb ; done all yet? + bne LD4C4 ; brif not +LD4D4 ldx FCBTMP ; get FCB pointer + ldu #DFLBUF ; reset buffer pointer to bottom of buffer area + stu FCBBUF,x + ldb VD8 ; first time through on PUT? + andb 7,s + beq LD4EA ; brif not + clr 7,s ; reset the "first time" flag + ldd 10,s ; get bytes in last sector + ora #0x80 ; set "pre-save" flag + std FCBLST,x ; set correct last sector size +LD4EA jmp LCB06 ; close the file +; DSKI$ command +DSKI bsr LD527 ; get drive, track, and sector + bsr LD51C ; evaluate frist string sand save descriptor address + pshs x + bsr LD51C ; evaluate second string and save descriptor address + pshs x + ldb #2 ; read operation + jsr LD58F ; read sector + ldu #DBUF0+128 ; point to second half + puls x ; get descriptor for second string + bsr LD508 ; stow second string + ldu #DBUF0 ; point to first half + puls x ; get descriptor for first string +LD508 pshs u,x ; save source data and descriptor + ldb #128 ; do 128 bytes exactly + jsr LB50F ; reserve space + leau ,x ; point to reserved space + puls x ; get string descriptor address + stb ,x ; save length in descriptor + stu 2,x ; save data pointer + puls x ; get buffer pointer +LD519 jmp LA59A ; copy bytes to string +LD51C jsr SYNCOMMA ; make sure there's a comma + ldx #LB357 ; point to variable evaluation routine + bsr LD553 ; evaluate variable +LD524 jmp LB146 ; make sure we have a string +LD527 jsr EVALEXPB ; evaluate 8 bit expression + cmpb #3 ; valid drive? + bhi LD54A ; brif not + pshs b ; save it + jsr LB738 ; evaluate track expression (after a comma) + cmpb #TRKMAX-1 ; valid track? + bhi LD54A ; brif not + pshs b ; save track number + jsr LB738 ; evaluate comma followed by sector number + stb DSEC ; set DSKCON variable + decb ; zero-base it + cmpb #SECMAX-1 ; is it a valid sector? + bhi LD54A ; brif not + puls a,b ; get drive and track + sta DCTRK ; set DSKCON + stb DCDRV + rts +LD54A jmp LB44A ; raise FC error +LD54D jsr SYNCOMMA ; insist on a comma + ldx #LB156 ; evaluate expression pointer +LD553 ldb DCDRV ; save drive, track, and sector values + ldu DCTRK + pshs u,b ; save them + jsr ,x ; evaluate variable or expression + puls b,u ; restore DSKCON + stb DCDRV + stu DCTRK + rts +; DSKO$ command +DSKO bsr LD527 ; evaluate drive, track, and sector + bsr LD54D ; evaluate string 1 + bsr LD524 ; make sure it's a string + ldx FPA0+2 ; get descriptor address + pshs x ; save it + bsr LD54D ; evaluate string 2 + jsr LB654 ; get string details + pshs x,b ; save them + clrb ; clear full sector (so junk doesn't get in if strings are short) + ldx #DBUF0 ; point to sector buffer +LD577 clr ,x+ ; clear a byte + decb ; done whole sector? + bne LD577 ; brif not + puls b,x ; get string data + ldu #DBUF0+128 ; point to second half of sector + bsr LD519 ; copy string data (anything over 128 will go in second I/O buffer so harmless) + puls x ; get first string + jsr LB659 ; fetch string details + ldu #DBUF0 ; point to start of sector buffer + bsr LD519 ; copy string data (this will overwrite up to 255 bytes!) + ldb #3 ; write operation +LD58F ldx #DBUF0 ; point to sector buffer + stx DCBPT + stb DCOPC ; set read/write + jmp LD6F2 ; go read/write sector +; DSKINI command +DSKINI lbeq LA61F ; error if no drive number specified + jsr LD256 ; parse driven umber + ldb #4 ; default skip factor is 4 + jsr GETCCH ; is there a skip factor? + beq LD5B2 ; brif not + jsr LB738 ; evaluate comma followed by skip factor + cmpb #17 ; max value is 16 + lbhs LB44A ; brif too high + jsr LA5C7 ; carp if there's anything else +LD5B2 pshs b ; save skip factor + ldx #DBUF1+SECMAX ; poitn to end of sector number scratch area + ldb #SECMAX ; get the maximum sector number +LD5B9 clr ,-x ; mark sector number unset + decb ; done all of them? + bne LD5B9 ; brif not + clra ; reset sector counter + bra LD5CE ; start assigning sector numbers +LD5C1 addb ,s ; add in skip factor +LD5C3 incb ; bump sector number +LD5C4 subb #SECMAX ; remove a whole track worth + bhs LD5C4 ; brif we can still do more + addb #SECMAX ; undo extra subtraction + tst b,x ; has this sector been numbered? + bne LD5C3 ; brif so - try again on next one +LD5CE inca ; bump sector number + sta b,x ; set actual sector number + cmpa #SECMAX ; done all? + blo LD5C1 ; brif not + leas 1,s ; remove skip factor - we don't need it + ldx #DFLBUF+0x1888-2 ; point to top of memory used by DSKINI (for track image) + cmpx MEMSIZ ; does it fit? + lbhi LAC44 ; brif not + jsr DVEC7 ; close files + com DRESFL ; cause reset of things + lds #DBUF1+SECLEN ; put stack somewhere safe + jsr L95AC ; reset display + lda #0 ; restore head to track 0 + sta DCOPC + ifeq DISKVER-1 + clr DCTRK ; set track number to 0 (used as a track counter for the format) + endc + jsr LD6F2 ; restorehead to track 0 + clr RDYTMR ; don't allow motor to turn off + lda #0xc0 ; FDC read address code + sta FDCREG ; instruct FDC + jsr LD7D1 ; wait until drive ready + ifeq DISKVER + lbne LD688 ; brif drive not ready + clr DCTRK ; reset track counter + bra LD620 ; go format tracks + else + beq LD620 ; brif drive ready + jmp LD688 ; raise error if not ready + endc +LD606 cmpa #22 ; precomp? + blo LD612 ; brif not + lda DRGRAM ; enable precomp + ora #0x10 + sta DSKREG +LD612 lda #0x53 ; "step in" + sta FDCREG ; go do a step + exg a,a ; wait for FDC status to stabilize + exg a,a + jsr LD7D1 ; wait for ready + bne LD688 ; bri fnot ready - raise error +LD620 jsr LD7F0 ; wait for a bit + bsr LD691 ; build formatted track + ldy #FDCREG+3 ; point to data register + orcc #0x50 ; disable interrupts + ldx #LD64F ; where to return to + stx DNMIVC ; set up NMI escaper + ldx #DFLBUF ; point to track image + lda FDCREG ; reset status of FDC + lda #0xff ; enable NMI escaper + sta NMIFLG + ldb #0xf4 ; write track command + stb FDCREG ; instruct FDC + lda DRGRAM ; enable HALT + ora #0x80 + sta DSKREG +LD649 ldb ,x+ ; fetch track byte + stb ,y ; stuff it out to FDC + bra LD649 ; do another ASAP (HALT will clock this) +LD64F lda FDCREG ; fetch status + andcc #0xaf ; restore interrupts + anda #0x44 ; keep only write protect and lost data + sta DCSTA ; save status + bne LD688 ; brif error + inc DCTRK ; bump track number + lda DCTRK ; done all tracks? + cmpa #TRKMAX + bne LD606 ; brif not + lda #2 ; DSKCON read operation + sta DCOPC + ldx #DBUF0 ; point to disk buffer + stx DCBPT + ldu #DBUF1 ; point to sector numbers + clra ; reset track counter +LD66F sta DCTRK ; set track + clrb ; reset sector counter +LD672 lda b,u ; get real sector number + sta DSEC ; tell DSKCON + jsr LD6F2 ; read a sector + incb ; bump sector counter + cmpb #SECMAX ; done whole track? + blo LD672 ; brif not + lda DCTRK ; get track number + inca ; bump it + cmpa #TRKMAX ; done all? + blo LD66F ; brif not + jmp LD2CD ; do the reset thing if needed +LD688 clr DRGRAM ; stop drive motors and selects + clr DSKREG + jmp LD701 ; wait for ready signal +LD691 ldx #DFLBUF ; point to track buffer + ldd #0x204e ; write out 32 * 0x4e + bsr LD6C2 + clrb ; reset sector counter +LD69A pshs b ; save sector counter + ldu #DBUF1 ; point to sector numbers + ldb b,u ; get real sector number + stb DSEC ; save it + ldu #LD6D4 ; point to format table for a sector + ldb #3 ; process three blocks + bsr LD6C8 + lda DCTRK ; save track number + sta ,x+ + clr ,x+ ; set side number to 0 + lda DSEC ; set sector number + sta ,x+ + ldb #9 ; process 9 blocks + bsr LD6C8 + puls b ; get sector counter + incb ; bump it + cmpb #SECMAX ; done all? + blo LD69A ; brif not - do another sector + ldd #0xc84e ; write 200 times 0x4e for track trailer +LD6C2 stb ,x+ ; stow a byte + deca ; done enough? + bne LD6C2 ; brif not + rts +LD6C8 pshs b ; save item counter + ldd ,u++ ; get count and data byte + bsr LD6C2 ; process it + puls b ; get item count back + decb ; done all? + bne LD6C8 ; brif not + rts +LD6D4 fcb 8,0 ; SYNC field + fcb 3,0xf5 + fcb 1,0xfe ; address mark + ; track, side, sector here + fcb 1,1 ; sector size flag + fcb 1,0xf7 ; CRC request + fcb 22,0x4e ; post-ID gap + fcb 12,0 ; sync field + fcb 3,0xf5 + fcb 1,0xfb ; data address mark + fcb 0,0xff ; default track data + fcb 1,0xf7 ; CRC request + fcb 24,0x4e ; post data gap + ifeq DISKVER-1 +; DOS command +DOS bne LD742 ; brif argument given + jmp [DOSVEC] ; transfer control to DOS command + endc +; General sector read/write routine; this implements VERIFY on write and does several retries +LD6F2 pshs b ; save register + ldb #5 ; we'll try 5 times on VERIFY failure + stb ATTCTR + puls b ; restore register +LD6FB bsr DSKCON ; execute command + tst DCSTA ; success? + beq LD70E ; brif so +LD701 lda DCSTA ; get status + ldb #2*30 ; code for write protect + bita #0x40 ; was it write protected? + bne LD70B ; brif so +LD709 ldb #2*20 ; I/O error code +LD70B jmp LAC46 ; raise error +LD70E pshs a ; save A + lda DCOPC ; was it write? + cmpa #3 + puls a ; restore register + bne LD742 ; brif not + tst DVERFL ; verify? + beq LD742 ; brif not + pshs u,x,b,a ; save registers + lda #2 ; set for read + sta DCOPC + ldu DCBPT ; get original buffer pointer + ldx #DBUF1 ; point to secondary buffer + stx DCBPT + bsr DSKCON ; read the sector + stu DCBPT ; restore buffer pointer + lda #3 ; restore write operation + sta DCOPC + lda DCSTA ; did we have a problem? + bne LD743 ; brif so + clrb ; check 256 bytes +LD737 lda ,x+ ; compare two bytes + cmpa ,u+ + bne LD743 ; brif no match - error + decb ; done all? + bne LD737 ; brif not + puls a,b,x,u ; restore registers +LD742 rts +LD743 puls a,b,x,u ; restore registers + dec ATTCTR ; tried enough times? + bne LD6FB ; brif not - try again + ldb #2*36 ; code for verify error + bra LD70B ; raise error +; VERIFY command +VERIFY clrb ; off flag + cmpa #0xaa ; OFF? + beq LD75A ; brif so + comb ; set to on flag + cmpa #0x88 ; ON? + lbne LB277 ; brif not - raise error +LD75A stb DVERFL ; set verify state + jmp GETNCH ; eat the ON/OFF and return +; DSKCON - the main disk I/O driver +DSKCON pshs u,y,x,b,a ; save registers + lda #5 ; retry 5 times + pshs a ; save retry counter +LD765 clr RDYTMR ; reset drive timeout (so drive won't turn off if it's already on) + ldb DCDRV ; get drive number + ldx #LD89D ; point to drive enable masks + lda DRGRAM ; get control register value + anda #0xa8 ; keep only motor, halt, double density + ora b,x ; set drive select lines + ora #0x20 ; set double density + ldb DCTRK ; get desired track + cmpb #22 ; precomp? + blo LD77E ; brif not + ora #0x10 ; enable precomp +LD77E tfr a,b ; save image prior to enabling motors + ora #8 ; turn on motors + sta DRGRAM ; actuall do all that stuff above + sta DSKREG + bitb #8 ; were motors already on? + bne LD792 ; brif so - don't wait + jsr LA7D1 ; wait quite a while + jsr LA7D1 ; wait quite a while longer +LD792 bsr LD7D1 ; wait until read + bne LD7A0 ; brif timed out + clr DCSTA ; clear status (set no error) + ldx #LD895 ; point to command jump table + ldb DCOPC ; get operation code + aslb ; two bytes per routine address + jsr [b,x] ; do operation +LD7A0 puls a ; get back retry count + ldb DCSTA ; get status + beq LD7B1 ; brif no error + deca ; retried enough? + beq LD7B1 ; brif so + pshs a ; save retry counter again + bsr LD7B8 ; restore head to track 0 + bne LD7A0 ; brif error + bra LD765 ; try command again +LD7B1 lda #120 ; drive timeout is 120 VSYNC ticks (2 seconds for 60Hz) + sta RDYTMR + puls a,b,x,y,u,pc ; restore registers and return +LD7B8 ldx #DR0TRK ; point to track table + ldb DCDRV ; get drive number + clr b,x ; mark drive on track 0 + lda #3 ; restore head to track 0, unloaded, 30ms step + sta FDCREG ; go do it + exg a,a ; wait for status to stabilize + exg a,a + bsr LD7D1 ; wait for ready + bsr LD7F0 ; wait somemore + anda #0x10 ; keep only seek error + sta DCSTA ; set result +LD7D0 rts +LD7D1 ldx ZERO ; get timeout counter +LD7D3 leax -1,x ; count down + beq LD7DF ; brif timed out + lda FDCREG ; get status + bita #1 ; is it ready? + bne LD7D3 ; brif not + rts +LD7DF lda #0xd0 ; force interrupt + sta FDCREG + exg a,a ; wait for status to stabilize + exg a,a + lda FDCREG ; clear status + lda #0x80 ; return not ready status + sta DCSTA + rts +LD7F0 ldx #8750 ; delay for about half of a long while +LD7F3 leax -1,x ; count down + bne LD7F3 ; brif not done + rts +LD7F8 lda #0x80 ; code for read sector + skip2 +LD7FB lda #0xa0 ; code for write sector + pshs a ; save operation + ldx #DR0TRK ; point to track state table + ldb DCDRV ; get drive number + abx ; point to correct drive table + ldb ,x ; get current track number + stb FDCREG+1 ; tell FDC about it + cmpb DCTRK ; is it the one we want? + beq LD82C ; brif so - no stepping needed + lda DCTRK ; get desired track + sta FDCREG+3 ; tell the FDC that too + sta ,x ; record that drive is there + lda #0x17 ; seek to desired track, unloaded, 30ms step, verify destination + sta FDCREG + exg a,a ; wait for status to be stable + exg a,a + bsr LD7D1 ; wait for ready + bne LD82A ; brif timed out + bsr LD7F0 ; wait some more + anda #0x18 ; keep only seek error or CRC error in ID + beq LD82C ; brif no errors + sta DCSTA ; save error state +LD82A puls a,pc ; clean up stack and return +LD82C lda DSEC ; get desired sector + sta FDCREG+2 ; tell FDC + ldx #LD88B ; point to escape routine + stx DNMIVC ; set up NMI escaper + ldx DCBPT ; point to I/O buffer + lda FDCREG ; reset FDC status + lda DRGRAM ; get control register image + ora #0x80 ; enable HALT + puls b ; get operation code + ldy ZERO ; timeout value + ldu #FDCREG ; point to FDC + com NMIFLG ; enable escaper + orcc #0x50 ; disable interrupts + stb FDCREG ; give FDC its marching orders + exg a,a ; wait for stable status + exg a,a + cmpb #0x80 ; read? + beq LD875 ; brif so + ldb #2 ; DRQ mask +LD85B bitb ,u ; is it ready for a byte? + bne LD86B ; brif not + leay -1,y ; timed out? + bne LD85B ; brif not +LD863 clr NMIFLG ; disable NMI escaper + andcc #0xaf ; enable interrupts + jmp LD7DF ; force interrupt, etc. +LD86B ldb ,x+ ; get byte from buffer + stb FDCREG+3 ; send it out + sta DSKREG ; reprogram control register + bra LD86B ; send more +LD875 ldb #2 ; DRQ mask bit +LD877 bitb ,u ; is a byte ready? + bne LD881 ; brif not + leay -1,y ; timed out? + bne LD877 ; brif not + bra LD863 ; bail out +LD881 ldb FDCREG+3 ; get input data + stb ,x+ ; put in buffer + sta DSKREG ; reprogram control register + bra LD881 ; read more +LD88B andcc #0xaf ; enable interrupts + lda FDCREG ; get status from FDC + anda #0x7c ; keep write protect, write fault, not found, CRC, or lost data + sta DCSTA ; set status + rts +LD895 fdb LD7B8 ; reset head to track 0 + fdb LD7D0 ; no-op - just spin up drives + fdb LD7F8 ; read sector + fdb LD7FB ; write sector +LD89D fcb 0x01 ; drive select 0 + fcb 0x02 ; drive select 1 + fcb 0x04 ; drive select 2 + fcb 0x40 ; drive select 3/side select +; NMI handler +DNMISV lda NMIFLG ; is the escaper enabled? + beq LD8AE ; brif not + ldx DNMIVC ; set return to escape hatch + stx 10,s + clr NMIFLG ; disable escaper now that we used it +LD8AE rti +; Disk IRQ handler +DIRQSV lda PIA0+3 ; is it VSYNC? + bpl LD8AE ; brif HSYNC + lda PIA0+2 ; clear interrupt status + lda RDYTMR ; are drives waiting to stop? + beq LD8CD ; brif not + deca ; count down a tick + sta RDYTMR ; save new count + bne LD8CD ; brif they haven't timed out yet + lda DRGRAM ; get control register image + anda #0xb0 ; turn off motors and drive selects + sta DRGRAM + sta DSKREG +LD8CD jmp L8955 ; transfer control to Extended Basic's handler + ifeq DISKVER-1 +; From here to the DOS command is unused + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 + fcb 0x13,0x34,0x06,0x9D,0xA5,0x27,0x03,0xBD,0x95,0x81,0x96,0xB5,0x97,0xD8,0x35,0x06 + fcb 0xDD,0xB4,0x4F,0x34,0x56,0xBD,0x95,0x22,0xBD,0x92,0x8F,0xDF,0xD9,0xBD,0x99,0xDF + fcb 0x27,0x0F,0xBD,0x99,0xCB,0x86,0x01,0x97,0xD7,0xBD,0x99,0xBA,0x00,0xD7,0xBD,0x99 + fcb 0xBA,0x10,0xDF,0xDC,0x0D,0xDB,0x26,0x03,0x10,0xDE,0xDC,0x35,0x56,0x0F,0xDB,0x10 + fcb 0xDF,0xDC,0x30,0x01,0x9F,0xBD,0xDF,0xD1,0x97,0xD7,0x27,0x9F,0x2B,0x06,0x5C,0xD1 + fcb 0xD6,0x23,0x05,0x5F,0x5D,0x27,0xDD,0x5A,0xD7,0xC0,0xBD,0x99,0xDF,0x27,0x0F,0x10 + fcb 0x83,0x00,0x03,0x25,0x04,0x30,0x1E,0x8D,0x38,0xBD,0x99,0xCB,0x8D,0x4C,0x43,0x53 + fcb 0xD3,0xD1,0xDD,0xD1,0x2F,0x16,0xBD,0x95,0x06,0xBD,0x9A,0x12,0x26,0x05,0xCC,0xFF + fcb 0xFF,0x20,0xED,0xBD,0x95,0x14,0x8D,0x3E,0x8D,0x5E,0x20,0xE0,0xBD,0x95,0x06,0x30 + fcb 0x8B,0x9F,0xBD,0x43,0x53,0x83,0x00,0x01,0x2F,0x04,0x1F,0x01,0x8D,0x03,0x7E,0x99 + fcb 0x34,0xDD,0xCB,0x35,0x20,0xDC,0xBD,0x34,0x16,0x96,0xD7,0x40,0xD6,0xC0,0x34,0x06 + fcb 0x34,0x20,0xC6,0x02,0xBD,0xAC,0x33,0xDC,0xCB,0x39,0xDD,0xCB,0x35,0x20,0xDC,0xC3 + fcb 0x34,0x16,0x96,0xD7,0x20,0xE6,0x9E,0xBD,0x9F,0xC3,0x39,0xDD,0xCD,0x10,0x9E,0xC3 + fcb 0x8D,0xF4,0x10,0x9F,0xBD,0x8D,0x11,0x9E,0xCD,0x30,0x8B,0xC3,0x00,0x01,0x39,0xBD + fcb 0x99,0xC6,0x10,0x8E,0x95,0x14,0x20,0x06,0x10,0x8E,0x95,0x06,0xAD,0xA4,0xDE,0x8A + fcb 0x9E,0xBD,0x2B,0x17,0x9C,0xD3,0x22,0x13,0x34,0x60,0x8D,0x16,0x27,0x0B,0xBD,0x93 + fcb 0x77,0x35,0x60,0x33,0x41,0xAD,0xA4,0x20,0xE9,0x35,0x60,0x1F,0x30,0x1F,0x01,0x93 + fcb 0x8A,0x39,0xAD,0x9F,0x00,0xD9,0x1F,0x89,0xD4,0xD8,0x34,0x06,0xA4,0x84,0xA1,0x61 + fcb 0x35,0x86,0x9E,0x8A,0xC6,0x01,0x34,0x14,0xBD,0xB1,0x56,0x5F,0xBD,0xA9,0xA2,0xBD + fcb 0xA9,0x76,0xBD,0xB6,0x54,0x20,0x02,0x35,0x14,0xD7,0xD8,0x27,0xFA,0x9F,0xD9,0x10 + fcb 0x27,0x0F,0x31,0x0D,0xD8,0x27,0xF0,0xBD,0x9B,0x98,0x81,0x3B,0x27,0xF5,0x81,0x27 + fcb 0x27,0xF1,0x81,0x58,0x10,0x27,0x01,0xB2,0x8D,0x02,0x20,0xE7,0x81,0x4F,0x26,0x0D + fcb 0xD6,0xDE,0x5C,0x8D,0x5B,0x5A,0xC1,0x04,0x22,0x63,0xD7,0xDE,0x39,0x81,0x56,0x26 + fcb 0x1A,0xD6,0xDF,0x54,0x54,0xC0,0x1F,0x8D,0x47,0xC1,0x1F,0x22,0x50,0x58,0x58,0x34 + fcb 0x04,0xCC,0x7E,0x7E,0xAB,0xE4,0xE0,0xE0,0xDD,0xDF,0x39,0x81,0x4C,0x26,0x23,0xD6 + fcb 0xE1,0x8D,0x2D,0x5D,0x27,0x37,0xD7,0xE1,0x0F,0xE5,0x8D,0x03,0x24,0xFC,0x39,0x0D + fcb 0xD8,0x27,0x0A,0xBD,0x9B,0x98,0x81,0x2E,0x27,0x05,0xBD,0x9B,0xE2,0x43,0x39,0x0C + fcb 0xE5,0x39,0x81,0x54,0x26,0x0D,0xD6,0xE2,0x8D,0x06,0x5D,0x27,0x10,0xD7,0xE2,0x39 + fcb 0x7E,0x9B,0xAC,0x81,0x50,0x26,0x24,0xBD,0x9C,0xCB,0x5D,0x26,0x03,0x7E,0xB4,0x4A + fcb 0x96,0xE5,0x9E,0xDF,0x34,0x12,0x86,0x7E,0x97,0xDF,0x97,0xE0,0x0F,0xE5,0x8D,0x07 + fcb 0x35,0x12,0x97,0xE5,0x9F,0xDF,0x39,0x6F,0xE2,0x20,0x40,0x81,0x4E,0x26,0x03,0xBD + fcb 0x9B,0x98,0x81,0x41,0x25,0x04,0x81,0x47,0x23,0x05,0xBD,0x9B,0xBE,0x20,0x23,0x80 + fcb 0x41,0x8E,0x9C,0x5B,0xE6,0x86,0x0D,0xD8,0x27,0x18,0xBD,0x9B,0x98,0x81,0x23,0x27 + fcb 0x04,0x81,0x2B,0x26,0x03,0x5C,0x20,0x0A,0x81,0x2D,0x26,0x03,0x5A,0x20,0x03,0xBD + fcb 0x9B,0xE2,0x5A,0xC1,0x0B,0x22,0xA6,0x34,0x04,0xD6,0xE1,0x96,0xE2,0x3D,0xDD,0xD5 + fcb 0x33,0x61,0x96,0xDE,0x81,0x01,0x22,0x2C,0x8E,0x9C,0x62,0xC6,0x18,0x3D,0x3A,0x35 + fcb 0x04,0x58,0x3A,0x31,0x84,0x8D,0x45,0xDD,0xE3,0x8D,0x0C,0x96,0xDF,0x8D,0x0B,0x8D + fcb 0x06,0x96,0xE0,0x8D,0x05,0x20,0xF2,0x86,0x7E,0x12,0xB7,0xFF,0x20,0xAE,0xA4,0x30 + fcb 0x1F,0x26,0xFC,0x39,0x8E,0x9C,0x7A,0xC6,0x0C,0x3D,0x3A,0x35,0x04,0x3A,0x8D,0x1C + fcb 0xDD,0xE3,0x8D,0x0C,0x96,0xDF,0x8D,0x0B,0x8D,0x06,0x96,0xE0,0x8D,0x05,0x20,0xF2 + fcb 0x86,0x7E,0x12,0xB7,0xFF,0x20,0xA6,0x84,0x4A,0x26,0xFD,0x39,0xC6,0xFF,0x96,0xE5 + fcb 0x27,0x05,0x8B,0x02,0x3D,0x44,0x56,0x39,0x34,0x10,0x0D,0xD8,0x27,0x4D,0x9E,0xD9 + fcb 0xA6,0x80,0x9F,0xD9,0x0A,0xD8,0x81,0x20,0x27,0xF0,0x35,0x90,0x8D,0xEA,0x81,0x2B + fcb 0x27,0x3C,0x81,0x2D,0x27,0x3C,0x81,0x3E,0x27,0x42,0x81,0x3C,0x27,0x39,0x81,0x3D + fcb 0x27,0x3F,0xBD,0x90,0xAA,0x25,0x24,0x5F,0x80,0x30,0x97,0xD7,0x86,0x0A,0x3D,0x4D + fcb 0x26,0x19,0xDB,0xD7,0x25,0x15,0x0D,0xD8,0x27,0x17,0xBD,0x9B,0x98,0xBD,0x90,0xAA + fcb 0x24,0xE6,0x0C,0xD8,0x9E,0xD9,0x30,0x1F,0x9F,0xD9,0x39,0x7E,0xB4,0x4A,0x5C,0x27 + fcb 0xFA,0x39,0x5D,0x27,0xF6,0x5A,0x39,0x5D,0x27,0xF1,0x54,0x39,0x5D,0x2B,0xEC,0x58 + fcb 0x39,0x34,0x60,0x8D,0x16,0xBD,0xB7,0x0E,0x35,0xE0,0xBD,0x9C,0x1B,0xC6,0x02,0xBD + fcb 0xAC,0x33,0xD6,0xD8,0x9E,0xD9,0x34,0x14,0x7E,0x9A,0x32,0x9E,0xD9,0x34,0x10,0xBD + fcb 0x9B,0x98,0xBD,0xB3,0xA2,0x25,0xC4,0xBD,0x9B,0x98,0x81,0x3B,0x26,0xF9,0x35,0x10 + fcb 0xDE,0xA6,0x34,0x40,0x9F,0xA6,0xBD,0xB2,0x84,0x35,0x10,0x9F,0xA6,0x39,0x4F,0x1F + fcb 0x8B,0xDC,0xE3,0x10,0x27,0x0D,0x74,0x93,0xD5,0xDD,0xE3,0x22,0x0D,0x0F,0xE3,0x0F + fcb 0xE4,0x35,0x02,0x10,0xEE,0x67,0x84,0x7F,0x34,0x02,0x3B,0x0A,0x0C,0x01,0x03,0x05 + fcb 0x06,0x08,0x01,0xA8,0x01,0x90,0x01,0x7A,0x01,0x64,0x01,0x50,0x01,0x3D,0x01,0x2B + fcb 0x01,0x1A,0x01,0x0A,0x00,0xFB,0x00,0xED,0x00,0xDF,0x00,0xD3,0x00,0xC7,0x00,0xBB + fcb 0x00,0xB1,0x00,0xA6,0x00,0x9D,0x00,0x94,0x00,0x8B,0x00,0x83,0x00,0x7C,0x00,0x75 + fcb 0x00,0x6E,0xA6,0x9C,0x93,0x8B,0x83,0x7B,0x74,0x6D,0x67,0x61,0x5B,0x56,0x51,0x4C + fcb 0x47,0x43,0x3F,0x3B,0x37,0x34,0x31,0x2E,0x2B,0x28,0x26,0x23,0x21,0x1F,0x1D,0x1B + fcb 0x19,0x18,0x16,0x14,0x13,0x12,0x9E,0x8A,0xC6,0x01,0x34,0x14,0xD7,0xC2,0x9F,0xD5 + fcb 0xBD,0x95,0x9A,0xBD,0xB1,0x56,0xBD,0xB6,0x54,0x20,0x08,0xBD,0x9B,0x98,0x7E,0x9B + fcb 0xBE,0x35,0x14,0xD7,0xD8,0x27,0xFA,0x9F,0xD9,0x10,0x27,0x00,0xEA,0x0D,0xD8,0x27 + fcb 0xF0,0xBD,0x9B,0x98,0x81,0x3B,0x27,0xF5,0x81,0x27,0x27,0xF1,0x81,0x4E,0x26,0x04 + fcb 0x03,0xD5,0x20,0xE9,0x81,0x42,0x26,0x04,0x03,0xD6,0x20,0xE1,0x81,0x58,0x10,0x27 + fcb 0x00,0x96,0x81,0x4D,0x10,0x27,0x01,0x2A,0x34,0x02,0xC6,0x01,0x0D,0xD8,0x27,0x11 + fcb 0xBD,0x9B,0x98,0xBD,0xB3,0xA2,0x34,0x01,0xBD,0x9B,0xE2,0x35,0x01,0x24,0x02,0x8D + fcb 0xAA,0x35,0x02,0x81,0x43,0x27,0x28,0x81,0x41,0x27,0x2E,0x81,0x53,0x27,0x32,0x81 + fcb 0x55,0x27,0x5C,0x81,0x44,0x27,0x55,0x81,0x4C,0x27,0x4C,0x81,0x52,0x27,0x43,0x80 + fcb 0x45,0x27,0x2F,0x4A,0x27,0x27,0x4A,0x27,0x32,0x4A,0x27,0x1D,0x7E,0xB4,0x4A,0xBD + fcb 0x95,0x5D,0xD7,0xB2,0xBD,0x95,0x9A,0x20,0x84,0xC1,0x04,0x24,0xEF,0xD7,0xE8,0x20 + fcb 0xF6,0xC1,0x3F,0x24,0xE7,0xD7,0xE9,0x20,0xEE,0x4F,0x8D,0x58,0x21,0x4F,0x1F,0x01 + fcb 0x20,0x59,0x4F,0x1F,0x01,0x8D,0x4D,0x1E,0x01,0x20,0x50,0x4F,0x1F,0x01,0x8D,0x44 + fcb 0x20,0x49,0x4F,0x9E,0x8A,0x20,0x44,0x4F,0x8D,0x3A,0x20,0xF7,0x4F,0x20,0x03,0x4F + fcb 0x8D,0x32,0x9E,0x8A,0x1E,0x10,0x20,0x33,0xBD,0x9C,0x1B,0xC6,0x02,0xBD,0xAC,0x33 + fcb 0xD6,0xD8,0x9E,0xD9,0x34,0x14,0x7E,0x9C,0xC6,0xD6,0xE9,0x27,0x1B,0x4F,0x1E,0x01 + fcb 0xA7,0xE2,0x2A,0x02,0x8D,0x0D,0xBD,0x9F,0xB5,0x1F,0x30,0x44,0x56,0x44,0x56,0x6D + fcb 0xE0,0x2A,0x04,0x40,0x50,0x82,0x00,0x39,0x1F,0x10,0x39,0x34,0x06,0x8D,0xDA,0x35 + fcb 0x10,0x34,0x06,0x8D,0xD4,0x35,0x10,0x10,0x9E,0xE8,0x34,0x20,0x6D,0xE4,0x27,0x08 + fcb 0x1E,0x10,0x8D,0xDF,0x6A,0xE4,0x20,0xF4,0x35,0x20,0xDE,0x8A,0xD3,0xC7,0x2B,0x02 + fcb 0x1F,0x03,0x1F,0x10,0x9E,0x8A,0xD3,0xC9,0x2B,0x02,0x1F,0x01,0x11,0x83,0x01,0x00 + fcb 0x25,0x03,0xCE,0x00,0xFF,0x8C,0x00,0xC0,0x25,0x03,0x8E,0x00,0xBF,0xDC,0xC7,0xDD + fcb 0xBD,0xDC,0xC9,0xDD,0xBF,0x9F,0xC5,0xDF,0xC3,0x0D,0xD5,0x26,0x04,0x9F,0xC9,0xDF + fcb 0xC7,0xBD,0x94,0x20,0x0D,0xD6,0x26,0x03,0xBD,0x94,0xA1,0x0F,0xD5,0x0F,0xD6,0x7E + fcb 0x9C,0xDD,0xBD,0x9B,0x98,0x34,0x02,0xBD,0x9E,0x5E,0x34,0x06,0xBD,0x9B,0x98,0x81 + fcb 0x2C,0x10,0x26,0xFF,0x07,0xBD,0x9E,0x5B,0x1F,0x01,0x35,0x40,0x35,0x02,0x81,0x2B + fcb 0x27,0x04,0x81,0x2D,0x26,0xA6,0x1F,0x30,0x7E,0x9D,0xCB,0xBD,0x9B,0x98,0x81,0x2B + fcb 0x27,0x07,0x81,0x2D,0x27,0x04,0xBD,0x9B,0xE2,0x4F,0x34,0x02,0xBD,0x9C,0xCB,0x35 + fcb 0x02,0x4D,0x27,0x04,0x4F,0x50,0x82,0x00,0x39,0x00,0x00,0x00,0x01,0xFE,0xC5,0x19 + fcb 0x19,0xFB,0x16,0x31,0xF2,0xF4,0xFB,0x4A,0x51,0xEC,0x84,0x61,0xF9,0xE1,0xC7,0x78 + fcb 0xAE,0xD4,0xDC,0x8E,0x3B,0xC5,0xE5,0xA2,0x69,0xB5,0x06,0xB5,0x06,0x81,0x40,0x26 + fcb 0x02,0x9D,0x9F,0xBD,0x95,0x22,0xBD,0x93,0xB2,0xBD,0x93,0x1D,0xAE,0xC4,0x9F,0xCB + fcb 0xAE,0x42,0x9F,0xCD,0xBD,0xB2,0x6D,0xBD,0xB7,0x3D,0xCE,0x00,0xCF,0xAF,0xC4,0xBD + fcb 0x93,0x20,0x86,0x01,0x97,0xC2,0xBD,0x95,0x81,0x8E,0x01,0x00,0x9D,0xA5,0x27,0x0F + fcb 0xBD,0xB2,0x6D,0xBD,0xB1,0x41,0x96,0x4F,0x8B,0x08,0x97,0x4F,0xBD,0xB7,0x40,0x96 + fcb 0xB6,0x85,0x02,0x27,0x04,0x1F,0x10,0x30,0x8B,0x9F,0xD1,0xC6,0x01,0xD7,0xC2,0xD7 + fcb 0xD8,0xBD,0x9F,0xE2,0x34,0x06,0xBD,0x9F,0xE2,0xDD,0xD9,0x35,0x06,0x34,0x06,0x9E +; The actual implementation of the DOS command follows; presumably this is here because it was +; implemented by a different group of people given that it doesn't call DSKCON directly and uses +; the DSKCON variables pointer as well. +DOSCOM swi3 ; do a software interrupt for some reason (why?) + clr TMPLOC ; reset sector counter + ldd #DOSBUF ; initialize load address for boot track + pshs d ; save buffer address +LDF09 ldx DSKVAR ; point to DSKCON variables + inc TMPLOC ; bump sector counter + lda TMPLOC ; get current sector + cmpa #SECMAX ; loaded whole track? + bhi LDF36 ; brif so + sta 3,x ; tell DSKCON the sector number + ldd #0x0200 ; read code and drive 0 + sta ,x ; set operation code (should be std to set drive) + lda #34 ; track 34 + sta 2,x ; tell DSKCON + puls a,b ; get buffer pointer + std 4,x ; tell DSKCON + adda #1 ; bump buffer pointer by one sector + pshs a,b ; save it again + jsr [DCNVEC] ; call DSKCON to read a sector + tst 6,x ; error? + beq LDF09 ; brif not - read another + puls a,b ; clean stack + ldb #2*20 ; I/O error code + jmp LAC46 ; raise error +LDF36 puls a,b ; clear up stack + ldd DOSBUF ; get start of loaded track + cmpd #'O*256+'S ; is it the "OS" tag? + lbeq DOSBUF+2 ; brif so - transfer control to it + clr DOSBUF ; clear first two bytes (why?) + clr DOSBUF+1 + jmp BAWMST ; do a warm start +DOSINI ldd #0x3b3b ; set up SWI3 and SWI2 with RTIs (kind of pointless) + std SW3VEC + std SW3VEC+2 + std SW2VEC+1 + rts +; The remainder to the end is unused garbage bytes + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x05,0x10,0x93,0xD3,0x25,0x02,0xDC,0xD3,0xDD + fcb 0xC3,0xA6,0xE4,0x81,0x04,0x25,0x0A,0xDC,0xCD,0x93,0xC5,0x24,0x11,0x4F,0x5F,0x20 + fcb 0x0D,0xDC,0xCD,0xD3,0xC5,0x25,0x05,0x10,0x93,0xD5,0x25,0x02,0xDC,0xD5,0xDD,0xC5 + fcb 0x0D,0xD8,0x26,0x02,0x8D,0x50,0x35,0x06,0x04,0xD8,0x25,0x05,0x10,0x93,0xD9,0x27 + fcb 0x0C,0x5C,0xC1,0x08,0x26,0x04,0x4C,0x5F,0x84,0x07,0x7E,0x9E,0xFD,0x39,0x9E,0xCF + fcb 0xEC,0xC4,0x27,0x07,0x83,0x00,0x01,0x8D,0x03,0x1F,0x21,0x39,0x34,0x76,0x6F,0x64 + fcb 0xA6,0x63,0x3D,0xED,0x66,0xEC,0x61,0x3D,0xEB,0x66,0x89,0x00,0xED,0x65,0xE6,0xE4 + fcb 0xA6,0x63,0x3D,0xE3,0x65,0xED,0x65,0x24,0x02,0x6C,0x64,0xA6,0xE4,0xE6,0x62,0x3D + fcb 0xE3,0x64,0xED,0x64,0x35,0xF6,0x7E,0x94,0xA1,0x5F,0x9D,0xA5,0x27,0x11,0xBD,0xB2 + fcb 0x6D,0xBD,0xB1,0x41,0x96,0x4F,0x8B,0x06,0x97,0x4F,0xBD,0xB7,0x0E,0xC4,0x3F,0x1F + fcb 0x98,0xC4,0x07,0x44,0x44,0x44,0x39 + else +; From here to the end of the ROM is unused garbage bytes + fcb 0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 + fcb 0xa7,0xfc,0x8f,0xec,0x94,0xbc,0x8c,0xf5 + fcb 0xbc,0xf8,0xd1,0xfa,0xfd,0xfd,0xac,0xe5 + fcb 0xec,0xf8,0x8a,0xea,0xad,0xec,0xb9,0xff + fcb 0xbc,0xfd,0xcc,0xed,0x8c,0xe5,0x9c,0xf4 + fcb 0xa2,0xa6,0xe8,0xfc,0xae,0xe5,0x94,0xec + fcb 0xbe,0xee,0x8c,0xed,0xea,0xe5,0xed,0x7c + fcb 0xbe,0xfc,0x8e,0xed,0xfe,0xec,0x9c,0xac + fcb 0xdc,0xfd,0xfb,0xf5,0xad,0xfd,0xaf,0xe9 + fcb 0xa0,0x30,0x24,0x8a,0x14,0x84,0x2c,0xc4 + fcb 0x24,0x08,0xe0,0x21,0x20,0x80,0x28,0x00 + fcb 0x20,0x88,0xa4,0xa0,0xa4,0x80,0xac,0x11 + fcb 0x30,0x90,0x24,0xd4,0x01,0xa1,0xa0,0x84 + fcb 0x64,0x80,0x34,0x04,0x34,0x80,0x20,0x21 + fcb 0xa1,0x81,0xa4,0x80,0x20,0x90,0x88,0xc0 + fcb 0x00,0x9a,0xa0,0xa0,0xe0,0x80,0xb6,0xa4 + fcb 0x20,0xa2,0x20,0x98,0x20,0x88,0x7c,0xae + fcb 0xbd,0xee,0xee,0xfe,0xf1,0xec,0xad,0xbc + fcb 0xed,0xec,0xdd,0xf9,0xec,0x75,0xb5,0xbd + fcb 0xef,0xfd,0xa9,0xe4,0x96,0xfc,0x94,0xe4 + fcb 0xae,0xad,0xda,0xb4,0xac,0x7c,0xc3,0xec + fcb 0xbd,0xfc,0xae,0xfd,0xee,0xfd,0x85,0xf4 + fcb 0xad,0xef,0x76,0xfc,0xd6,0x6e,0xef,0xed + fcb 0xf6,0xbd,0xed,0xfe,0x58,0xed,0xf7,0xfd + fcb 0x85,0xec,0xfc,0xe8,0xf2,0xe4,0xbf,0xa8 + fcb 0x30,0x80,0xa0,0x05,0xa4,0x20,0xb0,0x80 + fcb 0x20,0x84,0x04,0x80,0x30,0x8e,0xe0,0xa4 + fcb 0xb0,0x02,0x04,0x80,0x61,0x84,0x20,0x00 + fcb 0xa0,0x80,0x20,0x88,0x24,0x94,0x24,0xa4 + fcb 0x80,0x04,0x00,0x84,0x24,0x84,0x28,0x9c + fcb 0x44,0x28,0xa0,0x80,0x80,0x90,0x30,0x80 + fcb 0xe8,0x80,0xa4,0x88,0x30,0x94,0x20,0x80 + fcb 0x00,0x8c,0x68,0xac,0xa4,0x84,0x30,0x06 + fcb 0x86,0xe4,0xbc,0xfc,0xae,0xec,0x87,0xbd + fcb 0x9c,0xfd,0xec,0xbc,0xfd,0xb5,0xa9,0xed + fcb 0xa7,0xac,0x8b,0x7c,0xa5,0xfc,0xcc,0xbc + fcb 0xaa,0xb6,0xc9,0xfc,0xa5,0xfc,0x47,0xfc + fcb 0xdd,0x6d,0x84,0xfe,0xac,0xee,0x20,0xf4 + fcb 0xc5,0xff,0xf4,0xee,0xf7,0xf4,0xaa,0xfc + fcb 0xef,0xff,0x9c,0xfd,0xee,0xe4,0xaf,0xfc + fcb 0xbe,0xbc,0xdf,0xa5,0xeb,0xec,0xee,0xa4 + fcb 0x34,0x86,0xac,0x84,0xa4,0x21,0x90,0x88 + fcb 0xa0,0xa0,0x24,0xc0,0xe0,0x80,0x70,0xe5 + fcb 0x3c,0xa5,0xa1,0x8c,0x34,0xa4,0xe4,0x84 + fcb 0x24,0x80,0xf8,0x81,0xa0,0x8d,0xec,0x4a + fcb 0x2c,0xe2,0xa4,0x93,0x20,0x88,0xb0,0xc0 + fcb 0x34,0x10,0x20,0x91,0xa4,0x84,0xa4,0xae + fcb 0x0c,0x92,0xb0,0xcd,0xb0,0xaa,0x74,0xe8 + fcb 0xa0,0x12,0xb9,0x85,0x21,0xf5,0xe0,0x8e + fcb 0x9e,0xbd,0x81,0xf5,0xcf,0xe4,0xcc,0x66 + fcb 0xa7,0xad,0x98,0xbd,0xbc,0xbc,0x88,0xbc + fcb 0x8e,0xed,0xa4,0xa8,0xad,0x88,0xee,0xfe + fcb 0xcd,0xfc,0xac,0xfd,0x8c,0xfc,0x9a,0xf5 + fcb 0xb4,0xe4,0x8e,0xfc,0xfe,0xe4,0xcc,0xac + fcb 0x9d,0xfc,0x97,0xe4,0x8b,0xec,0xea,0xec + fcb 0xdb,0xec,0xdf,0xec,0xac,0xe4,0xae,0xfc + fcb 0xd4,0xf4,0xcd,0xec,0xb4,0xec,0xef,0xee + fcb 0xb2,0x24,0x28,0x20,0xac,0xd0,0x24,0x1c + fcb 0x30,0x81,0xac,0x84,0x80,0x01,0xa4,0xa4 + fcb 0x70,0x88,0xa4,0xc4,0xa4,0x84,0x24,0x60 + fcb 0x08,0x04,0xa0,0x88,0x20,0x98,0x64,0xa8 + fcb 0x24,0x10,0xd4,0x90,0xa0,0x81,0x30,0xec + fcb 0xac,0x09,0x64,0xe0,0x60,0x18,0x30,0xb0 + fcb 0x24,0x80,0x6c,0x88,0xa4,0x8c,0xa4,0x8c + fcb 0xa8,0x10,0x21,0xa8,0x68,0x84,0xa8,0xa0 + fcb 0x8d,0xe5,0xa4,0x66,0x98,0xfd,0x87,0xfc + fcb 0xde,0xac,0x9c,0xf4,0x8c,0xf5,0xb5,0xf5 + fcb 0xb6,0xf5,0xa9,0xf8,0xaf,0xed,0xe6,0xe5 + fcb 0xb8,0xf1,0xb1,0xfc,0xfc,0xe9,0x8c,0xec + fcb 0x86,0xf9,0xb5,0xf7,0xcd,0xbc,0x84,0xe6 + fcb 0x8c,0xfc,0x81,0xe4,0xbc,0xe4,0x4f,0xfc + fcb 0x8c,0xfc,0xae,0xe7,0xbd,0xfc,0xdc,0xfc + fcb 0xf4,0xe8,0x9f,0xec,0xea,0xfc,0xef,0x6c + fcb 0x20,0x82,0xa4,0x40,0xa8,0x8c,0xac,0x08 + fcb 0x60,0x82,0xa1,0x95,0xe0,0x30,0x60,0x80 + fcb 0x64,0x48,0x20,0x04,0x20,0x84,0xa4,0x82 + fcb 0xa0,0x04,0x20,0x94,0x44,0xa0,0xe0,0x80 + fcb 0x04,0xc8,0x2c,0x82,0x24,0x04,0x30,0xb8 + fcb 0x24,0x00,0x20,0xa0,0xa4,0x82,0xa0,0x80 + fcb 0x84,0x81,0x2c,0x84,0x20,0x80,0x24,0x8c + fcb 0x80,0x80,0x24,0x02,0x64,0xa8,0x24,0x88 + fcb 0xed,0xbd,0xd1,0xff,0xb4,0xe4,0xaa,0xec + fcb 0x80,0xf1,0x8c,0xed,0x89,0xac,0xb6,0xfc + fcb 0x6e,0xfd,0xae,0xed,0x89,0xec,0xb6,0xec + fcb 0xae,0xfd,0xee,0xf0,0x9f,0x7e,0x9f,0xfe + fcb 0xd9,0xec,0xae,0xed,0xc6,0xec,0xfe,0x7d + fcb 0xbc,0xfc,0xb9,0xac,0xda,0xfc,0xa5,0xbd + fcb 0xcc,0xfd,0xad,0xe6,0xae,0xf4,0xcd,0xf4 + fcb 0xf2,0xed,0x84,0x78,0xcc,0xec,0xab,0x74 + fcb 0xa4,0x94,0x20,0x84,0x20,0x00,0xa0,0x00 + fcb 0xa4,0x05,0x28,0x0c,0x24,0x04,0x24,0x00 + fcb 0xa0,0x84,0x80,0x80,0x18,0x80,0x24,0x0c + fcb 0xe0,0x88,0x04,0x8a,0x2c,0x88,0x0c,0x84 + fcb 0x00,0x80,0xe0,0x04,0x20,0xa1,0x20,0x85 + fcb 0x20,0x90,0x80,0x9c,0x24,0xc0,0xe0,0x8d + fcb 0xa0,0x80,0x20,0x82,0xa0,0xa2,0x20,0x40 + fcb 0x80,0x82,0x10,0xb8,0x00,0x84,0x60,0x92 + fcb 0xdf,0xef,0xd1,0xec,0xa4,0xec,0xc9,0xfd + fcb 0xe6,0xad,0xc6,0xe5,0xd4,0xfd,0x9a,0xed + fcb 0xae,0xe4,0xac,0xbc,0x9f,0xec,0x8a,0xed + fcb 0x0f,0xe5,0x8f,0xec,0xd7,0xe4,0xac,0xec + fcb 0xce,0xef,0x9e,0xf4,0xd7,0xe4,0xcf,0xf5 + fcb 0xce,0xf4,0xe6,0x6c,0x81,0xec,0x9b,0xee + fcb 0x9f,0x7c,0xbc,0xf7,0xcc,0x6d,0xfe,0xef + fcb 0x8e,0x6e,0xef,0xbd,0xbe,0xbd,0x8f,0xe4 + fcb 0xa0,0x04,0x20,0xe0,0xb4,0x82,0xb4,0x82 + fcb 0x20,0x8c,0xb0,0x90,0xb0,0x90,0xb8,0x84 + fcb 0x24,0x90,0x6a,0x86,0x28,0x84,0xa0,0xa8 + fcb 0x24,0xcf,0xb8,0x88,0xa0,0xa0,0xb1,0x81 + fcb 0x10,0xb6,0xe0,0x98,0xc8,0xb4,0x34,0xaf + fcb 0x34,0x00,0xb0,0x82,0x20,0x90,0xe4,0xac + fcb 0x28,0x84,0x84,0x88,0x24,0xac,0xac,0xa4 + fcb 0x25,0x98,0x20,0xa0,0x20,0x80,0x32,0x00 + fcb 0xae,0xec,0x8d,0xbd,0x9f,0xf7,0xff,0xa1 + fcb 0xca,0xbe,0x8d,0x7c,0x8e,0x74,0xef,0xec + fcb 0xd4,0xf5,0x9e,0xb8,0x8e,0x35,0xc6,0xe4 + fcb 0x90,0xed,0xed,0xfc,0x8c,0x25,0xbe,0xa4 + fcb 0xfc,0x6c,0x89,0xee,0xec,0xad,0xae,0x78 + fcb 0xee,0xec,0xad,0xed,0xad,0xec,0xbc,0xbd + fcb 0x2e,0x76,0xae,0xec,0x8e,0xbd,0xef,0xfd + fcb 0xac,0xec,0xef,0xb5,0xbe,0xa4,0xbf,0xe8 + fcb 0x04,0x00,0x24,0x08,0x04,0x84,0x24,0x80 + fcb 0x28,0x82,0x60,0x04,0x24,0x94,0x28,0x00 + fcb 0x2c,0x84,0x20,0x80,0xb5,0x86,0x30,0x04 + fcb 0x23,0x84,0xa0,0x80,0xa0,0x06,0x24,0xad + fcb 0xa4,0x80,0xa6,0x86,0x80,0x00,0xe0,0x80 + fcb 0x66,0x90,0x20,0x8c,0x00,0x8c,0x04,0x82 + fcb 0xa4,0x46,0x00,0x01,0x20,0x98,0xa0,0x88 + fcb 0x20,0x2a,0x24,0xe0,0x00,0x08,0x64,0x02 + fcb 0x8d,0xa5,0xb5,0xe5,0xad,0xf7,0xcd,0xf4 + fcb 0xa8,0x29,0xbc,0x64,0xf8,0xec,0xad,0xae + fcb 0xa8,0xf5,0x8c,0xa7,0xe7,0xe5,0xa9,0xf4 + fcb 0xf4,0xfd,0x94,0xed,0x5c,0xe4,0xc0,0xbe + fcb 0x8c,0xfd,0xcd,0xa4,0x94,0xff,0xa5,0xec + fcb 0xfc,0xe5,0xac,0xe4,0xae,0xbd,0x9d,0xbd + fcb 0xa8,0xec,0x84,0x68,0xc9,0xad,0x8e,0xac + fcb 0xea,0xed,0x8f,0xec,0xbf,0xaf,0xf7,0xed + fcb 0x24,0x91,0xa0,0x04,0xb4,0x04,0x82,0x90 + fcb 0xac,0x08,0xb0,0xa0,0xc0,0x08,0x34,0xa0 + fcb 0x65,0x88,0x73,0x80,0x20,0x80,0x2c,0x04 + fcb 0x20,0x84,0x21,0x26,0x20,0x94,0x00,0x20 + fcb 0xa4,0x96,0xa4,0x80,0xb0,0x84,0x24,0x82 + fcb 0x25,0x86,0xa0,0x00,0x7c,0x30,0xa2,0x25 + fcb 0x24,0x9e,0xa0,0x88,0x20,0x80,0x20,0x00 + fcb 0x20,0xa9,0x20,0xa2,0xc0,0xb2,0xa1,0x0e + fcb 0xae,0xec,0xa8,0xee,0xac,0xf8,0xfa,0xb4 + fcb 0xa4,0xfe,0xfc,0xf4,0x1c,0xed,0xae,0xf4 + fcb 0xd7,0xf8,0xfd,0xed,0x8e,0xfe,0xdc,0xe8 + fcb 0xfe,0xed,0xfc,0xed,0x9f,0xfc,0x9c,0xed + fcb 0xb0,0xe7,0xbe,0xfe,0x84,0xe4,0xa7,0xfe + fcb 0xad,0xe4,0xbc,0x64,0x8d,0xbf,0xaf,0xfd + fcb 0xaa,0x2c,0xcd,0xed,0x8f,0xe4,0xfc,0xbd + fcb 0xbf,0xef,0xe5,0xed,0xbf,0xfe,0xe5,0xfd + fcb 0x84,0x82,0xa4,0x83,0xa4,0x08,0xa0,0x80 + fcb 0x00,0x84,0x30,0x86,0x08,0x20,0xb0,0x90 + fcb 0x14,0xb4,0xa0,0x80,0x20,0x90,0xa4,0x88 + fcb 0xec,0x80,0xa4,0x84,0xa0,0x84,0x28,0x80 + fcb 0xb4,0x81,0xf0,0xa0,0xe4,0x80,0x00,0x84 + fcb 0x34,0xb1,0xe4,0x80,0x24,0x5d,0x20,0xd2 + fcb 0x44,0x83,0xb0,0x88,0x20,0x14,0x30,0xbc + fcb 0x20,0xa0,0xc4,0x9d,0x68,0x00,0xa0,0x20 + fcb 0xcf,0xec,0xaa,0x66,0xb8,0x75,0x9e,0xfc + fcb 0xfe,0xb4,0xbc,0xff,0xac,0xfd,0x9a,0xbc + fcb 0xba,0xec,0x8e,0xf4,0xec,0xfc,0x96,0xfd + fcb 0xd2,0xea,0x84,0xfc,0xae,0xe4,0xe5,0xfd + fcb 0xbd,0xec,0xdc,0xac,0xa5,0xb0,0xcf,0xec + fcb 0x7a,0xb5,0xe4,0xea,0xef,0xec,0xa4,0xfe + fcb 0xe5,0xff,0xf8,0xbc,0x86,0xe4,0xff,0xe5 + fcb 0xaf,0x6c,0xee,0xec,0xee,0x6c,0x2a,0x6c + fcb 0x28,0xa0,0x64,0x84,0xb4,0x92,0x04,0x94 + fcb 0x80,0x00,0xb8,0x0c,0x20,0x88,0xa0,0x84 + fcb 0xa0,0x40,0xb0,0x00,0xa0,0x84,0xa0,0xca + fcb 0x00,0x14,0x24,0xc0,0xa0,0x64,0x24,0x88 + fcb 0x00,0x18,0xed,0x88,0x28,0x80,0xa1,0x80 + fcb 0x00,0x85,0x20,0x80,0xa4,0x34,0x00,0x04 + fcb 0x24,0xa4,0xac,0x8c,0x34,0x88,0x2c,0x04 + fcb 0x24,0x84,0x60,0x88,0xa0,0xa0,0xa0,0x9c + fcb 0xb9,0xf4,0x97,0xec,0x68,0xad,0xe4,0xf0 + fcb 0xf4,0xec,0xcb,0xfc,0xa8,0xf5,0xfd,0x3e + fcb 0xfc,0xee,0x9d,0xec,0x5e,0xfc,0x9c,0xf6 + fcb 0x80,0xed,0xa2,0xe4,0xad,0xb6,0xbf,0xf4 + fcb 0xed,0xfe,0xb3,0xfc,0xdc,0xb5,0xb3,0xed + fcb 0xef,0xfc,0xbf,0xfc,0xbc,0xfe,0xea,0xf4 + fcb 0xc5,0xe4,0x89,0xfc,0x7c,0xbd,0xde,0xfd + fcb 0x87,0xe4,0x9e,0xec,0xaf,0xe4,0xfe,0xe4 + fcb 0x34,0xc6,0x30,0x26,0x24,0x80,0x20,0x1c + fcb 0xb4,0x04,0xb4,0x28,0x24,0x98,0x20,0x00 + fcb 0xa4,0xa4,0xa0,0x80,0x21,0x48,0xb9,0x24 + fcb 0x20,0x80,0x28,0x00,0x20,0x80,0x84,0x1e + fcb 0x60,0xbc,0x28,0x88,0xac,0x74,0xe0,0x04 + fcb 0x24,0xa6,0x00,0x20,0x70,0x85,0xa0,0x89 + fcb 0x30,0x0b,0xa0,0x80,0x20,0x10,0xa0,0x14 + fcb 0x24,0x04,0x20,0x82,0xa0,0x80,0x35,0xa0 + fcb 0xee,0xbc,0xbe,0xfd,0xbe,0xb9,0x89,0xe4 + fcb 0xfd,0x3d,0x13,0xe4,0x9e,0xec,0x8d,0xec + fcb 0xde,0xfc,0x8e,0xe5,0x8f,0xf4,0xbe,0xff + fcb 0xe6,0xe6,0x8c,0xe6,0xcd,0xae,0xee,0xed + fcb 0xfe,0xec,0xdc,0xec,0x8e,0xfc,0x96,0xfd + fcb 0xa6,0xfc,0xce,0xcd,0xbe,0xfe,0xee,0xfc + fcb 0x9e,0xf4,0xee,0x6e,0xcf,0xed,0xee,0xe0 + fcb 0xfc,0xee,0xae,0xa0,0xfd,0xed,0xa6,0x6c + fcb 0xa8,0x04,0x20,0x00,0x30,0x80,0xa0,0x90 + fcb 0x20,0x80,0x60,0x00,0x20,0x82,0x90,0x40 + fcb 0x24,0x10,0x04,0x00,0x84,0x00,0x24,0x18 + fcb 0xe0,0x00,0x00,0x02,0x20,0xb4,0x24,0x00 + fcb 0x22,0x80,0x04,0x04,0xa0,0x80,0x84,0x0a + fcb 0x28,0x14,0xa0,0x80,0x00,0x86,0x40,0x86 + fcb 0x20,0x90,0x10,0x30,0x84,0x84,0x00,0x00 + fcb 0x74,0x80,0x30,0x00,0x20,0x08,0x20,0x80 + fcb 0xfb,0xfd,0xc9,0xe6,0x91,0xfd,0xc8,0xee + fcb 0xb4,0x7c,0xbe,0xec,0x89,0xec,0xbd,0xfc + fcb 0xa5,0xfd,0xd9,0xec,0x8a,0xfd,0xae,0xec + fcb 0xad,0xfc,0xae,0xec,0x8d,0xec,0x8f,0xf4 + fcb 0xbf,0x6d,0xac,0xbd,0xea,0xed,0xaf,0xac + fcb 0xfd,0xfc,0xea,0xfd,0xf0,0xf9,0xb3,0xee + fcb 0x8e,0xe4,0xfd,0xec,0xff,0xe0,0x8e,0xe4 + fcb 0xfd,0xad,0xdc,0x6c,0xa0,0xe4,0x8e,0xe4 + fcb 0x28,0x00,0xb4,0x00,0x22,0x00,0xb4,0x00 + fcb 0x6c,0x00,0xa4,0x1b,0xb2,0x9c,0x20,0x84 + fcb 0x24,0xc4,0x24,0xa8,0xa0,0x80,0x64,0x88 + fcb 0x80,0xac,0x30,0x85,0x20,0x9c,0x74,0xf2 + fcb 0x88,0x88,0x38,0x80,0x2c,0xa0,0x20,0x04 + fcb 0xb8,0x80,0x24,0x90,0xa8,0xf8,0xbc,0x88 + fcb 0x20,0x20,0xa0,0xe0,0x6c,0x80,0x00,0xe8 + fcb 0x20,0x80,0x24,0xc0,0x23,0x9c,0x24,0x82 + fcb 0xb5,0xe0,0xa4,0xed,0x8e,0xe4,0xa9,0xfc + fcb 0xf8,0xee,0xce,0xfc,0x89,0xe4,0x98,0xf5 + fcb 0xa1,0xec,0xa1,0xe0,0xb8,0xec,0xd0,0xfc + fcb 0xcf,0xf9,0xae,0xec,0x8a,0xfd,0x6b,0x6e + fcb 0x94,0xa8,0xb8,0xe4,0xce,0xa6,0x8c,0xf4 + fcb 0xee,0xbd,0x8d,0xec,0xed,0xf4,0xcf,0x6c + fcb 0x99,0x6c,0xc8,0xf9,0xf9,0xa5,0xb6,0x79 + fcb 0x8c,0xc1,0xe4,0xf5,0xaa,0x24,0xf7,0x64 + fcb 0x24,0xa8,0xa4,0x80,0xa0,0x96,0x20,0x09 + fcb 0x20,0x18,0xa8,0x08,0xb0,0xc0,0x7c,0xcd + fcb 0x24,0xdc,0x20,0x98,0x64,0x84,0xe0,0x82 + fcb 0x34,0xa0,0xea,0x88,0x60,0xc4,0x70,0xe8 + fcb 0x30,0x06,0xe5,0x1c,0x20,0x84,0x20,0x9c + fcb 0xa0,0x80,0xa0,0x1c,0xa8,0x80,0x88,0x22 + fcb 0x24,0x80,0x24,0xb0,0xe4,0x14,0xe4,0x80 + fcb 0xe0,0x86,0x00,0xd6,0x8c,0x80,0xb8,0xab + fcb 0xaf,0xa2,0x84,0xe8,0x86,0x2f,0x8a,0xf5 + fcb 0xd4,0xff,0x86,0xef,0x8e,0xf4,0xc8,0x6c + fcb 0xf5,0xf4,0x4c,0xf4,0xe8,0x74,0x04,0xee + fcb 0xee,0xe0,0x26,0x2c,0x9f,0xec,0x90,0xe5 + fcb 0xbc,0xe5,0xf8,0xe0,0xfb,0xf4,0xb4,0xed + fcb 0x4e,0xe4,0xe6,0xec,0x8c,0xe4,0xbf,0xed + fcb 0x9f,0xe0,0xcc,0x7c,0xbf,0xed,0x9d,0xed + fcb 0xad,0xf8,0xaf,0x64,0xef,0xed,0xed,0xe4 + fcb 0xa0,0x8c,0x20,0x95,0x30,0x38,0xa0,0x84 + fcb 0x64,0x80,0xe0,0x76,0x2c,0x20,0xb4,0x04 + fcb 0x3f,0xb1,0xa4,0x24,0x24,0x80,0x24,0xa9 + fcb 0x31,0x97,0xac,0x28,0x64,0x50,0xa0,0x04 + fcb 0x38,0x80,0xb4,0x8e,0x20,0xcc,0xbc,0x38 + fcb 0x64,0x8c,0xa0,0x90,0xe4,0xa0,0x64,0x99 + fcb 0x64,0xaf,0x24,0xe5,0x60,0x80,0xa4,0x3c + fcb 0x2c,0x8e,0xb4,0xbc,0xa4,0xcc,0x24,0xcc + endc
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/exbas10.s Sat Dec 08 19:57:01 2018 -0700 @@ -0,0 +1,4033 @@ + *pragma nolist + include defs.s +; These are the entry points in the Color Basic ROM which are used the the Extended Basic ROM. +; They are included here in order to keep the Extended Basic ROM separate from the Color Basic +; ROM. +BAWMST EQU 0xA0E8 +CLOAD EQU 0xA498 +CSAVE EQU 0xA44C +DATA EQU 0xAEE0 +EVALEXPB EQU 0xB70B +GIVABF EQU 0xB4F4 +INT EQU 0xBCEE +LA0E2 EQU 0xA0E2 +LA171 EQU 0xA171 +LA176 EQU 0xA176 +LA35F EQU 0xA35F +LA3ED EQU 0xA3ED +LA406 EQU 0xA406 +LA429 EQU 0xA429 +LA42D EQU 0xA42D +LA444 EQU 0xA444 +LA491 EQU 0xA491 +LA505 EQU 0xA505 +LA578 EQU 0xA578 +LA59A EQU 0xA59A +LA5A5 EQU 0xA5A5 +LA5AE EQU 0xA5AE +LA5C7 EQU 0xA5C7 +LA5E4 EQU 0xA5E4 +LA616 EQU 0xA616 +LA619 EQU 0xA619 +LA635 EQU 0xA635 +LA644 EQU 0xA644 +LA648 EQU 0xA648 +LA65F EQU 0xA65F +LA7E9 EQU 0xA7E9 +LA974 EQU 0xA974 +LA976 EQU 0xA976 +LA9A2 EQU 0xA9A2 +LA9BB EQU 0xA9BB +LAC1E EQU 0xAC1E +LAC33 EQU 0xAC33 +LAC46 EQU 0xAC46 +LAC60 EQU 0xAC60 +LAC73 EQU 0xAC73 +LAC7C EQU 0xAC7C +LAC9D EQU 0xAC9D +LACA8 EQU 0xACA8 +LACEF EQU 0xACEF +LACF1 EQU 0xACF1 +LAD01 EQU 0xAD01 +LAD19 EQU 0xAD19 +LAD21 EQU 0xAD21 +LAD26 EQU 0xAD26 +LAD33 EQU 0xAD33 +LAD9E EQU 0xAD9E +LADC6 EQU 0xADC6 +LADD4 EQU 0xADD4 +LADEB EQU 0xADEB +LAE15 EQU 0xAE15 +LAED2 EQU 0xAED2 +LAF67 EQU 0xAF67 +LAFA4 EQU 0xAFA4 +LB035 EQU 0xB035 +LB141 EQU 0xB141 +LB143 EQU 0xB143 +LB146 EQU 0xB146 +LB156 EQU 0xB156 +LB158 EQU 0xB158 +LB244 EQU 0xB244 +LB262 EQU 0xB262 +LB267 EQU 0xB267 +LB26A EQU 0xB26A +LB26F EQU 0xB26F +LB277 EQU 0xB277 +LB284 EQU 0xB284 +LB2CE EQU 0xB2CE +LB357 EQU 0xB357 +LB35C EQU 0xB35C +LB3A2 EQU 0xB3A2 +LB44A EQU 0xB44A +LB4F3 EQU 0xB4F3 +LB50F EQU 0xB50F +LB518 EQU 0xB518 +LB51A EQU 0xB51A +LB56D EQU 0xB56D +LB643 EQU 0xB643 +LB654 EQU 0xB654 +LB657 EQU 0xB657 +LB659 EQU 0xB659 +LB69B EQU 0xB69B +LB6A4 EQU 0xB6A4 +LB6AD EQU 0xB6AD +LB70E EQU 0xB70E +LB734 EQU 0xB734 +LB738 EQU 0xB738 +LB73D EQU 0xB73D +LB740 EQU 0xB740 +LB7C2 EQU 0xB7C2 +LB958 EQU 0xB958 +LB95C EQU 0xB95C +LB99F EQU 0xB99F +LB9AC EQU 0xB9AC +LB9AF EQU 0xB9AF +LB9B4 EQU 0xB9B4 +LB9B9 EQU 0xB9B9 +LB9C2 EQU 0xB9C2 +LBA1C EQU 0xBA1C +LBA3A EQU 0xBA3A +LBA92 EQU 0xBA92 +LBAC5 EQU 0xBAC5 +LBACA EQU 0xBACA +LBB48 EQU 0xBB48 +LBB5C EQU 0xBB5C +LBB6A EQU 0xBB6A +LBB82 EQU 0xBB82 +LBB8F EQU 0xBB8F +LBC14 EQU 0xBC14 +LBC2F EQU 0xBC2F +LBC35 EQU 0xBC35 +LBC4C EQU 0xBC4C +LBC5F EQU 0xBC5F +LBC6D EQU 0xBC6D +LBCA0 EQU 0xBCA0 +LBCC8 EQU 0xBCC8 +LBD99 EQU 0xBD99 +LBDB6 EQU 0xBDB6 +LBDBB EQU 0xBDBB +LBDC0 EQU 0xBDC0 +LBDC5 EQU 0xBDC5 +LBDCC EQU 0xBDCC +LBDD9 EQU 0xBDD9 +LBEC0 EQU 0xBEC0 +LBEC5 EQU 0xBEC5 +LBEE9 EQU 0xBEE9 +LBEF0 EQU 0xBEF0 +LBEFF EQU 0xBEFF +LBFA6 EQU 0xBFA6 +LET EQU 0xAF89 +PUTCHR EQU 0xA282 +SIN EQU 0xBF78 +SNDBLK EQU 0xA7F4 +STRINOUT EQU 0xB99C +SYNCOMMA EQU 0xB26D +WRLDR EQU 0xA7D8 + *pragma list +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; EXTENDED COLOR BASIC ROM +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + org EXBAS + fcc 'EX' ; magic number that Color Basic uses to identify the presence of Extended Basic +L8002 ldx #L80DE ; point to command interpretation table information + ldu #COMVEC+10 ; point to command interpretation table location + ldb #10 ; 10 bytes to move + jsr LA59A ; copy command interpretation table + ldx #LB277 ; initialize Disk Basic's entries to error + stx 3,u + stx 8,u + ldx #XIRQSV ; set up IRQ service routine + stx IRQVEC+1 + ldx ZERO ; reset the TIMER value + stx TIMVAL + jsr XVEC18 ; do a bunch of initialization + ldd #0x2c05 ; initialize DLOAD baud rate constant and timeout + std DLBAUD + ldx #USR0 ; set up pointer to USR routine addresses + stx USRADR + ldu #LB44A ; set up USR routine addresses to "FC error" + ldb #10 ; there are 10 routines +L8031 stu ,x++ ; set a routine to FC error + decb ; done all? + bne L8031 ; brif not + lda #0x7e ; op code of JMP extended (for RAM hook intialization) + sta RVEC20 ; command interpretation loop + ldx #XVEC20 + stx RVEC20+1 + sta RVEC15 ; expression evaluation + ldx #XVEC15 + stx RVEC15+1 + sta RVEC19 ; number parsing + ldx #XVEC19 + stx RVEC19+1 + sta RVEC9 ; PRINT + ldx #XVEC9 + stx RVEC9+1 + sta RVEC17 ; error handler + ldx #XVEC17 + stx RVEC17+1 + sta RVEC4 ; generic input + ldx #XVEC4 + stx RVEC4+1 + sta RVEC3 ; generic output + ldx #XVEC3 + stx RVEC3+1 + sta RVEC8 ; close file + ldx #XVEC8 + stx RVEC8+1 + sta RVEC23 ; tokenize line + ldx #XVEC23 + stx RVEC23+1 + sta RVEC18 ; RUN + ldx #XVEC18 + stx RVEC18+1 + sta EXPJMP ; exponentiation + ldx #L8489 + stx EXPJMP+1 + jsr L96E6 ; initialize graphics stuff + lda PIA0+3 ; enable 60Hz interrupt + ora #1 + sta PIA0+3 + ldx #'D*256+'K ; magic number for a Disk Basic ROM + cmpx DOSBAS ; do we have a Disk Basic ROM? + lbeq DOSBAS+2 ; brif so - launch it + andcc #0xaf ; enable interrupts + ldx #L80E8-1 ; show sign on message + jsr STRINOUT + ldx #XBWMST ; install warm start handler + stx RSTVEC + jmp LA0E2 ; set up warm start flag and launch immediate mode +; Extended Basic warm start code +XBWMST nop ; flag to mark routine as valid + clr PLYTMR ; cancel any PLAY command in progress + clr PLYTMR+1 + lda PIA0+3 ; enable 60Hz interrupt + ora #1 + sta PIA0+3 + jmp BAWMST ; let Color Basic's warm start process run +; This routine is dead code that is never used by any Basic ROMs. +L80D0 lda PIA1+2 ; check memory size jump + bita #2 + bne L80DA ; brif high + sta SAMREG+29 ; set SAM for 64K memory size +L80DA jmp ,x ; jump to address in X + fcb 0,0 ; dead space +L80DE fcb 25 ; 25 Extended Basic commands + fdb L8183 ; reserved word table (commands) + fdb L813C ; interpretation handler (commands) + fcb 14 ; 14 Extended Basic functions + fdb L821E ; reserved word table (functions) + fdb L8168 ; function handler +L80E8 fcc 'EXTENDED COLOR BASIC 1.0' + fcb 0x0d + fcc 'COPYRIGHT (C) 1980 BY TANDY' + fcb 0x0d + fcc 'UNDER LICENSE FROM MICROSOFT' + fcb 0x0d,0x0d,0x00 +; Extended Basic command interpretation loop +L813C cmpa #0xcb ; is it an Extended Basic command? + bhi L8148 ; brif not + ldx #L81F0 ; point to dispatch table + suba #0xb5 ; normalize the token number so 0 is the first entry + jmp LADD4 ; go transfer control to the command +L8148 cmpa #0xff ; is it a function token? + beq L8154 ; brif so - for MID$()=, TIMER= + cmpa #0xcd ; is it a token for a keyword that isn't a command? + bls L8165 ; brif so - error for USING and FN + jmp [COMVEC+23] ; transfer control to Disk Basic if it is present +L8154 jsr GETNCH ; get token after the function flag + cmpa #0x90 ; MID$? + lbeq L86D6 ; brif so (substring replacement) + cmpa #0x9f ; TIMER? + lbeq L8960 ; brif so - TIMER setting + jsr RVEC22 ; do a RAM hook in case something wants to extend this +L8165 jmp LB277 ; we have nothing valid here +; Function handler +L8168 cmpb #2*33 ; is it a valid Extended Basic function? + bls L8170 ; brif so + jmp [COMVEC+28] ; transfer control to Disk Basic if it is present +L8170 subb #2*20 ; normalize Extended Basic functions to 0 + cmpb #2*8 ; Above HEX$? + bhi L817D ; brif so - we don't pre-evaluate an argument + pshs b ; save token value + jsr LB262 ; evaluate the function parameter + puls b ; get back token value +L817D ldx #L8257 ; point to dispatch table + jmp LB2CE ; go transfer control to the function +; Reserved words (commands) +L8183 fcs 'DEL' ; 0xb5 + fcs 'EDIT' ; 0xb6 + fcs 'TRON' ; 0xb7 + fcs 'TROFF' ; 0xb8 + fcs 'DEF' ; 0xb9 + fcs 'LET' ; 0xba + fcs 'LINE' ; 0xbb + fcs 'PCLS' ; 0xbc + fcs 'PSET' ; 0xbd + fcs 'PRESET' ; 0xbe + fcs 'SCREEN' ; 0xbf + fcs 'PCLEAR' ; 0xc0 + fcs 'COLOR' ; 0xc1 + fcs 'CIRCLE' ; 0xc2 + fcs 'PAINT' ; 0xc3 + fcs 'GET' ; 0xc4 + fcs 'PUT' ; 0xc5 + fcs 'DRAW' ; 0xc6 + fcs 'PCOPY' ; 0xc7 + fcs 'PMODE' ; 0xc8 + fcs 'PLAY' ; 0xc9 + fcs 'DLOAD' ; 0xca + fcs 'RENUM' ; 0xcb + fcs 'FN' ; 0xcc + fcs 'USING' ; 0xcd +; Dispatch table (commands) +L81F0 fdb DEL ; 0xb5 DEL + fdb EDIT ; 0xb6 EDIT + fdb TRON ; 0xb7 TRON + fdb TROFF ; 0xb8 TROFF + fdb DEF ; 0xb9 DEF + fdb LET ; 0xba LET (note: implemented by Color Basic!) + fdb LINE ; 0xbb LINE + fdb PCLS ; 0xbc PCLS + fdb PSET ; 0xbd PSET + fdb PRESET ; 0xbe PRESET + fdb SCREEN ; 0xbf SCREEN + fdb PCLEAR ; 0xc0 PCLEAR + fdb COLOR ; 0xc1 COLOR + fdb CIRCLE ; 0xc2 CIRCLE + fdb PAINT ; 0xc3 PAINT + fdb GET ; 0xc4 GET + fdb PUT ; 0xc5 PUT + fdb DRAW ; 0xc6 DRAW + fdb PCOPY ; 0xc7 PCOPY + fdb PMODETOK ; 0xc8 PMODE + fdb PLAY ; 0xc9 PLAY + fdb DLOAD ; 0xca DLOAD + fdb RENUM ; 0xcb RENUM +; Reserved words (functions) +L821E fcs 'ATN' ; 0x94 + fcs 'COS' ; 0x95 + fcs 'TAN' ; 0x96 + fcs 'EXP' ; 0x97 + fcs 'FIX' ; 0x98 + fcs 'LOG' ; 0x99 + fcs 'POS' ; 0x9a + fcs 'SQR' ; 0x9b + fcs 'HEX$' ; 0x9c + fcs 'VARPTR' ; 0x9d + fcs 'INSTR' ; 0x9e + fcs 'TIMER' ; 0x9f + fcs 'PPOINT' ; 0xa0 + fcs 'STRING$' ; 0xa1 +; Dispatch table (functions) +L8257 fdb ATN ; 0x94 ATN + fdb COS ; 0x95 COS + fdb TAN ; 0x96 TAN + fdb EXP ; 0x97 EXP + fdb FIX ; 0x98 FIX + fdb LOG ; 0x99 LOG + fdb POS ; 0x9a POS + fdb SQR ; 0x9b SQR + fdb HEXDOL ; 0x9c HEX$ + fdb VARPTRTOK ; 0x9d VARPTR + fdb INSTR ; 0x9e INSTR + fdb TIMER ; 0x9f TIMER + fdb PPOINT ; 0xa0 PPOINT + fdb STRING ; 0xa1 STRING$ +; Generic output handler +XVEC3 tst DEVNUM ; screen? + lbeq L95AC ; brif so - force text screen active + pshs b ; save register + ldb DEVNUM ; get output device + cmpb #-3 ; check for DLOAD + puls b ; restore register + bne L8285 ; brif not DLOAD + leas 2,s ; bail out of output handler if DLOAD +L8285 rts +; Close file handler. This corrects a bug in Color Basic 1.0 which didn't handle writing the +; end of file block correctly. That bug is fixed in Color Basic 1.1 so this isn't required +; if a recent enough version of Color Basic is installed. +XVEC8 lda DEVNUM ; get device number + inca ; is it tape? + bne L8285 ; brif not - we aren't going to mess with it + lda FILSTA ; get tape file status + cmpa #2 ; output file? + bne L8285 ; brif not + lda CINCTR ; is there anything waiting to be written out? + bne L8285 ; brif so - mainline code will handle it properly + clr DEVNUM ; reset output to screen + leas 2,s ; don't return to mainline code + jmp LA444 ; write EOF block +; RUN handler - sets up some Extended Basic stuff to defaults at program start +XVEC18 ldd #0xba42 ; initialize PLAY volume + std VOLHI + lda #2 ; set PLAY tempo to 2, PLAY octave to 3 + sta TEMPO + sta OCTAVE + asla ; set default note length to 5 + sta NOTELN + clr DOTVAL ; don't do any note length extension + ldd ZERO ; initialize DRAW angle and scale to default 1 + std ANGLE + ldb #128 ; initialize horizontal and vertical default coordinates to the middle of the screen + std HORDEF + ldb #96 + std VERDEF + rts +; Command interpretation loop handler; we need to intercept this to implement TRON/TROFF +XVEC20 leas 2,s ; don't return to the mainline code +L82BB andcc #0xaf ; make sure interrupts are running + jsr LADEB ; do a BREAK/pause check + ldx CHARAD ; save input pointer + stx TINPTR + lda ,x+ ; get current input character + beq L82CF ; brif end of line + cmpa #': ; statement separator? + beq L82F1 ; brif so + jmp LB277 ; raise error we got here with extra junk +L82CF lda ,x++ ; get first byte of next line address + sta ENDFLG ; use it to set "END" flag to "END" + bne L82D8 ; brif not end of program + jmp LAE15 ; go do the "END" +L82D8 ldd ,x+ ; get line number of next line (and leave pointer one before line text) + std CURLIN ; set current line number + stx CHARAD ; save input pointer + lda TRCFLG ; are we tracing? + beq L82F1 ; brif not + lda #'[ ; show opening marker for TRON line number + jsr PUTCHR + lda CURLIN ; restore MSB of line number + jsr LBDCC ; show line number + lda #'] ; show closing marker for TRON line number + jsr PUTCHR +L82F1 jsr GETNCH ; get the start of the statement + tfr cc,b ; save status flags + cmpa #0x98 ; is it CSAVE? + beq L8316 ; brif so - go to Extended Basic patch (adds CSAVEM) + cmpa #0x97 ; is it CLOAD? + beq L8311 ; brif so - go to Extended Basic patch (adds multi-origin binaries) + tfr b,cc ; restore character status + jsr LADC6 ; go process command + bra L82BB ; restart interpretation loop +; Tokenizaton handler. This is actually a hack to intercept CLOAD and CSAVE during immediate mode by causing the +; tokenization routine to return to the interpretation loop above instead of the mainline interpretation loop. This +; is necessary because the first command encountered on a line in immediate mode is executed BEFORE the interpretation +; loop RAM hook is called. This patch doesn't actually affect tokenization itself at all. +XVEC23 ldx 2,s ; get return address of caller to the tokenizer + cmpx #LAC9D ; is it coming from immediate mode prior to executing the line? + bne L8310 ; brif not + ldx #L82F1 ; force return to Extended Basic's main loop patch above + stx 2,s +L8310 rts +; These two patches are set up this way so that control can be transferred back to the original Color Basic +; implementations if the Extended Basic addons are not triggered. +L8311 jsr L8C62 ; transfer control to Extended Basic's CLOAD handler + bra L82BB ; go do another command +L8316 bsr L831A ; go do Extended Basic's CSAVE handler + bra L82BB ; go do another command +; Extended Basic's CSAVE handler which implements CSAVEM (which Color Basic does not have) +L831A jsr GETNCH ; get character after CSAVE + cmpa #'M ; is it CSAVEM? + lbne CSAVE ; brif not - Color Basic can handle this + jsr GETNCH ; eat the "M" + jsr LA578 ; parse file name + bsr L836C ; get start address + stx CASBUF+13 ; save it in file header + bsr L836C ; get end address + cmpx 2,s ; compare to start address + lblo LB44A ; brif end address is before the start address + bsr L836C ; get execution address + stx CASBUF+11 ; put in file header + jsr GETCCH ; are we at the end of the commmand? + bne L8310 ; brif not + lda #2 ; file type to machine language + ldx ZERO ; set to binary and single block + jsr LA65F ; write header + clr FILSTA ; mark any open tape file closed + inc BLKTYP ; set block type to data + jsr WRLDR ; write a data leader + ldx 4,s ; get starting address +L834D stx CBUFAD ; set start of data address + lda #255 ; try a full length block by default + sta BLKLEN + ldd 2,s ; get ending address + subd CBUFAD ; see how much is left + bhs L835E ; brif we have more to write + leas 6,s ; clean up stack + jmp LA491 ; write EOF block +L835E cmpd #255 ; do we have a full block left? + bhs L8367 ; brif so + incb ; set block size to remainder + stb BLKLEN +L8367 jsr SNDBLK ; write a data block + bra L834D ; go see if we have more to write +L836C jsr SYNCOMMA ; make sure we have a comma + jsr LB73D ; evaluate unsigned expression to X + ldu ,s ; get return address + stx ,s ; save result on stack + tfr u,pc ; return to caller +; COS function +COS ldx #L83AB ; point to PI/2 constant + jsr LB9C2 ; add to argument ( cos(x) = sin((pi/2)+x) ) +L837E jmp SIN ; now calculate sin((pi/2)+x) +; TAN function. This is determined by the identity TAN(X) = SIN(X)/COS(X) +TAN jsr LBC2F ; save FPA0 in FPA3 + clr RELFLG ; reset quadrant flag + bsr L837E ; calculate SIN(x) + ldx #V4A ; save result in FPA5 + jsr LBC35 + ldx #V40 ; get back original argument + jsr LBC14 + clr FP0SGN ; force result positive + lda RELFLG ; get quadrant flag + bsr L83A6 ; calculate COS(x) + tst FP0EXP ; did we get 0 for COS(x) + lbeq LBA92 ; brif so - overflow + ldx #V4A ; point to sin(x) +L83A3 jmp LBB8F ; divide the sin(x) value by the cos(x) value +L83A6 pshs a ; save sign flag + jmp LBFA6 ; expand polynomial +L83AB fcb 0x81,0x49,0x0f,0xda,0xa2 ; pi/2 constant +; ATN function (inverse tangent). There are two calculation streams used to improve precision. +; One if the parameter is >= 1.0 and the other if it is < 1.0 +ATN lda FP0SGN ; get sign of argument + pshs a ; save it + bpl L83B8 ; brif positive + bsr L83DC ; flip sign of argument +L83B8 lda FP0EXP ; get exponent + pshs a ; save it + cmpa #0x81 ; exponent for 1.0 + blo L83C5 ; brif less - value is less than 1.0 + ldx #LBAC5 ; point to FP constant 1.0 + bsr L83A3 ; calculate reciprocal +L83C5 ldx #L83E0 ; point to polynomical coefficients + jsr LBEF0 ; expand polynomial + puls a ; get exponent of argument + cmpa #0x81 ; did we do a reciprocal calculation? + blo L83D7 ; brif not + ldx #L83AB ; subtract result from pi/2 if we did + jsr LB9B9 +L83D7 puls a ; get sign of original + tsta ; was it positive? + bpl L83DF ; brif so +L83DC jmp LBEE9 ; flip sign of result +L83DF rts +; Chebyshev modified taylor series coefficients for inverse tangent. Note that these diverge quite significantly +; from the standard taylor series after 1/9. The standard coefficients are 1/1,-1/3, 1/5, -1/7, 1/9, -1/11, and +; so on. These modified coefficients yield reasonable accuracy for the precision available, presumably with +; fewer coefficients. +L83E0 fcb 11 ; 12 coefficients + fcb 0x76,0xb3,0x83,0xbd,0xd3 ; -0.000684793912 + fcb 0x79,0x1e,0xf4,0xa6,0xf5 ; 0.00485094216 + fcb 0x7b,0x83,0xfc,0xb0,0x10 ; -0.0161117018 + fcb 0x7c,0x0c,0x1f,0x67,0xca ; 0.0342096381 + fcb 0x7c,0xde,0x53,0xcb,0xc1 ; -0.0542791328 + fcb 0x7d,0x14,0x64,0x70,0x4c ; 0.0724571965 + fcb 0x7d,0xb7,0xea,0x51,0x7a ; -0.0898023954 + fcb 0x7d,0x63,0x30,0x88,0x7e ; 0.110932413 + fcb 0x7e,0x92,0x44,0x99,0x3a ; -0.142839808 + fcb 0x7e,0x4c,0xcc,0x91,0xc7 ; 0.199999121 + fcb 0x7f,0xaa,0xaa,0xaa,0x13 ; -0.333333316 + fcb 0x81,0x00,0x00,0x00,0x00 ; 1.0 +; Chebyshev modified taylor series coefficients for the ln(x)/ln(2) (base 2 log of x) +L841D fcb 3 ; four coefficients + fcb 0x7f,0x5e,0x56,0xcb,0x79 ; 0.434255942 from (2/7)/ln(2) + fcb 0x80,0x13,0x9b,0x0b,0x64 ; 0.576584541 from (2/5)/ln(2) + fcb 0x80,0x76,0x38,0x93,0x16 ; 0.961800759 from (2/3)/ln(2) + fcb 0x82,0x38,0xaa,0x3b,0x20 ; 2.88539007 from 2/ln(2) +L8432 fcb 0x80,0x35,0x04,0xf3,0x34 ; 1/sqrt(2) +L8437 fcb 0x81,0x35,0x04,0xf3,0x34 ; sqrt(2) +L843C fcb 0x80,0x80,0x00,0x00,0x00 ; -0.5 +L8441 fcb 0x80,0x31,0x72,0x17,0xf8 ; ln(2) +; LOG function (natural log, ln) +; FP representation is of the form A*2^B. Thus, the log routine determines the value of +; ln(A*2^B). +; +; ln(A*2^B) = ln(A) + ln(2^B) = ln(A) + B*ln(2) = (ln(A)/ln(2) + B)*ln(2), OR: +; (log2(A) + B)*ln(2) +; Now if we write A as A*(sqrt(2)/sqrt(2)), we haven't changed anything so: +; (log2(A*sqrt(2)/sqrt(2)) + B)*ln(2) = (log2(A*sqrt(2)) - log2(sqrt(2)) + B) * ln(2) +; which gives: (-1/2 + log2(A*sqrt(2)) + B) * ln(2) +; +; Everything except log2(A*sqrt(2)) is either constant or trivial. +; +; What the actual code below feeds into the modified taylor series is actually: +; 1 - (sqrt(2)/(A + sqrt(2)) which algebra reveals to be (A*sqrt(2)-1)/(A*sqrt(2)+1) +; +; Thus, the code is using (A*sqrt(2)-1)/(A*sqrt(2)+1) instead of A*sqrt(2) as one would +; expect from the identities. However, the modified coefficients in the series above +; could be correcting for that or the introduced error was deemed acceptable. +; NOTE: this routine does NOT return 0 for LOG(1) +LOG jsr LBC6D ; get status of FPA0 + lble LB44A ; brif <= 0 - logarithms don't exist in that case + ldx #L8432 ; point to 1/sqrt(2) + lda FP0EXP ; get exponent of argument + suba #0x80 ; remove bias + pshs a ; save it for later + lda #0x80 ; force exponent to 0 (this turns FPA0 into A in the above description) + sta FP0EXP + jsr LB9C2 ; add 1/sqrt(2) to A + ldx #L8437 ; point to sqrt(2) + jsr LBB8F ; divide that by FPA0 + ldx #LBAC5 ; point to 1.0 + jsr LB9B9 ; subtract result from 1.0: Now FPA0 is 1-(sqrt(2)/(A+1/sqrt(2))) + ldx #L841D ; point to coefficients + jsr LBEF0 ; expand polynomial (calculate base 2 log of modified argument) + ldx #L843C ; point to -0.5 + jsr LB9C2 ; add result + puls b ; get original exponent back + jsr LBD99 ; add B to FPA0 + ldx #L8441 ; point to ln(2) + jmp LBACA ; multiply by ln(2) which gives us the result in base e +; SQR function (square root) - returns the principle root (positive) +SQR jsr LBC5F ; move argument to FPA1 (first argument for exponentiation) + ldx #LBEC0 ; point to 0.5 (exponent for square root) + jsr LBC14 ; set up second argument to exponentiation (the exponent) +; Exponentiation operator +; This is calculated as A^x = e^(x*ln(A)) where A is in FPA1 and x is in FPA0 +L8489 beq EXP ; do "EXP" if exponent is 0 (this will catch 0^0) + tsta ; check that the base is not 0 + bne L8491 ; brif base is not 0 + jmp LBA3A ; 0^(nonzero) is 0 +L8491 ldx #V4A ; save exponent (to FPA5) + jsr LBC35 + clrb ; result sign will default to positive + lda FP1SGN ; check if base is positive + bpl L84AC ; brif so + jsr INT ; convert exponent to integer + ldx #V4A ; point to original expoent + lda FP1SGN ; get sign of FPA1 + jsr LBCA0 ; compare original exponent with truncated one + bne L84AC ; brif not equal + coma ; flip sign + ldb CHARAC ; get LS byte of integer exponent (result sign flag) +L84AC jsr LBC4C ; copy FPA1 (base) to FPA0 (A = sign) + pshs b ; save result sign + jsr LOG ; get natural log of the base + ldx #V4A ; multiply the log by the exponent + jsr LBACA + bsr EXP ; now raise e to the resulting power + puls a ; get result sign + rora ; brif it was negative + lbcs LBEE9 ; brif negative - flip sign + rts +L84C4 fcb 0x81,0x38,0xaa,0x3b,0x29 ; 1.44269504 (correction factor for exponential function) +; Chebyshev modified taylor series coefficients for e^x +L84C9 fcb 7 ; eight coefficients + fcb 0x71,0x34,0x58,0x3e,0x56 ; 1/(7!*(CF^7)) + fcb 0x74,0x16,0x7e,0xb3,0x1b ; 1/(6!*(CF^6)) + fcb 0x77,0x2f,0xee,0xe3,0x85 ; 1/(5!*(CF^5)) + fcb 0x7a,0x1d,0x84,0x1c,0x2a ; 1/(4!*(CF^4)) + fcb 0x7c,0x63,0x59,0x58,0x0a ; 1/(3!*(CF^3)) + fcb 0x7e,0x75,0xfd,0xe7,0xc6 ; 1/(2!*(CF^2)) + fcb 0x80,0x31,0x72,0x18,0x10 ; 1/(1!*(CF^1)) + fcb 0x81,0x00,0x00,0x00,0x00 ; 1 +; EXP function (e^x) +EXP ldx #L84C4 ; point to correction factor + jsr LBACA ; multiply it + jsr LBC2F ; save corrected argument to FPA3 + lda FP0EXP ; get exponent of FPA0 + cmpa #0x88 ; is it too big? + blo L8504 ; brif not +L8501 jmp LBB5C ; to 0 (underflow) or overflow error +L8504 jsr INT ; convert argument to an integer + lda CHARAC ; get ls byte of integer + adda #0x81 ; was argument 127? if so, the OV error; adds bias + beq L8501 + deca ; adjust for the extra +1 above + pshs a ; save integer exponent + ldx #V40 ; get fractional part of argument + jsr LB9B9 + ldx #L84C9 ; point to coefficients + jsr LBEFF ; evaluate polynomial on the fractional part + clr RESSGN ; force result to be positive + puls a ; get back original exponent + jsr LBB48 ; add original exponent to the fractional result + rts +; FIX function (truncate/round toward 0) (NOTE: INT() always rounds down so INT(-0.5) gives -1 but FIX(-0.5) gives 0) +FIX jsr LBC6D ; get status of argument + bmi L852C ; brif negative +L8529 jmp INT ; do regular "int" if positive +L852C com FP0SGN ; flip the sign + bsr L8529 ; do "INT" on this + jmp LBEE9 ; flip the sign back +; EDIT command +EDIT jsr L89AE ; get line number + leas 2,s ; we're not going to return to the main loop +L8538 lda #1 ; "LIST" flag + sta VD8 ; set to list the line + jsr LAD01 ; find line number + lbcs LAED2 ; brif line wasn't found + jsr LB7C2 ; go unpack the line into the buffer + tfr y,d ; calculate the actual length of the line + subd #LINBUF+2 + stb VD7 ; save line length (it will only be 8 bits) +L854D ldd BINVAL ; get the line number + jsr LBDCC ; display it + jsr LB9AC ; put a space after it + ldx #LINBUF+1 ; point to iput uffer + ldb VD8 ; are we listing? + bne L8581 ; brif so +L855C clrb ; reset digit accumulator +L855D jsr L8687 ; get a keypress + jsr L90AA ; set carry if not numeric + bcs L8570 ; brif not a number + suba #'0 ; remove ASCII bias + pshs a ; save digit value + lda #10 ; multiply accumulator by 10 + mul + addb ,s+ ; add in new digit + bra L855D ; go check for another digit +L8570 subb #1 ; this converts 0 to 1, but *only* 0 to 1 + adcb #1 + cmpa #'A ; abort? + bne L857D ; brif not + jsr LB958 ; to a CR + bra L8538 ; restart EDIT process +L857D cmpa #'L ; list? + bne L858C ; brif not +L8581 bsr L85B4 ; list the line + clr VD8 ; reset to "not listing" + jsr LB958 ; do a CR + bra L854D ; start editing +L858A leas 2,s ; lose return address +L858C cmpa #0x0d ; ENTER? + bne L859D ; brif not + bsr L85B4 ; echo out the line +L8592 jsr LB958 ; do a CR + ldx #LINBUF+1 ; reset input pointer to start of buffer + stx CHARAD + jmp LACA8 ; join immediate mode to replace the line in the program +L859D cmpa #'E ; exit? + beq L8592 ; brif so - end edit with no echo + cmpa #'Q ; quit? + bne L85AB ; brif not + jsr LB958 ; do a CR + jmp LAC73 ; go to immediate mode with no fanfare - no changes saved +L85AB bsr L85AF ; go do commands + bra L855C ; go handle another command +L85AF cmpa #0x20 ; space? + bne L85C3 ; brif not + skip2 +L85B4 ldb #LBUFMX-1 ; display up to a whole line +L85B6 lda ,x ; get buffer chracter + beq L85C2 ; brif end of line + jsr PUTCHR ; output character + leax 1,x ; move to next character + decb ; done? + bne L85B6 ; brif not +L85C2 rts +L85C3 cmpa #'D ; delete? + bne L860F ; brif not +L85C7 tst ,x ; end of line? + beq L85C2 ; brif so - can't delete + bsr L85D1 ; remove a character + decb ; done all requested? + bne L85C7 ; brif not + rts +L85D1 dec VD7 ; account for character being removed + leay -1,x ; set pointer and compensate for increment below +L85D5 leay 1,y ; move to next character + lda 1,y ; get next character + sta ,y ; move it forward + bne L85D5 ; brif we didn't hit the end of the buffer + rts +L85DE cmpa #'I ; insert? + beq L85F5 ; brif so + cmpa #'X ; extend? + beq L85F3 ; brif so + cmpa #'H ; "hack"? + bne L8646 ; brif not + clr ,x ; mark current location as end of line + tfr x,d ; calculate new line length + subd #LINBUF+2 + stb VD7 ; save new length +L85F3 bsr L85B4 ; display the line +L85F5 jsr L8687 ; read a character + cmpa #0x0d ; ENTER? + beq L858A ; brif so - terminate entry + cmpa #0x1b ; ESC? + beq L8625 ; brif so - back to command mode + cmpa #0x08 ; backspace? + bne L8626 ; brif no + cmpx #LINBUF+1 ; are we at the start of the buffer? + beq L85F5 ; brif so - it's a no-op + bsr L8650 ; move pointer back one, do a BS + bsr L85D1 ; remove character from the buffer + bra L85F5 ; go handle more input +L860F cmpa #'C ; change? + bne L85DE ; brif not +L8613 tst ,x ; is there something to change? + beq L8625 ; brif not + jsr L8687 ; get a key stroke + bcs L861E ; brif valid key + bra L8613 ; try again if invalid key +L861E sta ,x+ ; put new character in the buffer + bsr L8659 ; echo it + decb ; changed number requested? + bne L8613 ; brif not +L8625 rts +L8626 ldb VD7 ; get length of line + cmpb #LBUFMX-1 ; at maximum line length? + bne L862E ; brif not + bra L85F5 ; process another input character +L862E pshs x ; save input pointer +L8630 tst ,x+ ; are we at the end of the line? + bne L8630 ; brif not +L8634 ldb ,-x ; get character before current pointer, move back + stb 1,x ; move it forward + cmpx ,s ; at the original buffer pointer? + bne L8634 ; brif not + leas 2,s ; remove saved buffer pointer + sta ,x+ ; save input character in newly made hole + bsr L8659 ; echo it + inc VD7 ; bump line length counter + bra L85F5 ; go handle more stuff +L8646 cmpa #0x08 ; backspace? + bne L865C ; brif not +L864A bsr L8650 ; move pointer back, echo BS + decb ; done enough of them? + bne L864A ; brif not + rts +L8650 cmpx #LINBUF+1 ; at start of buffer? + beq L8625 ; brif so + leax -1,x ; move pointer back + lda #0x08 ; character to echo - BS +L8659 jmp PUTCHR ; echo character to screen +L865C cmpa #'K ; "kill"? + beq L8665 ; brif so + suba #'S ; search? + beq L8665 ; brif so + rts +L8665 pshs a ; save kill/search flag + bsr L8687 ; read target + pshs a ; save search character +L866B lda ,x ; get current character in buffer + beq L8685 ; brif end of line - nothing more to search + tst 1,s ; is it KILL? + bne L8679 ; brif so + bsr L8659 ; echo the character + leax 1,x ; move ahead + bra L867C ; check next character +L8679 jsr L85D1 ; remove character from buffer +L867C lda ,x ; get character in buffer + cmpa ,s ; are we at the target? + bne L866B ; brif not + decb ; have we found enough of them? + bne L866B ; brif not +L8685 puls y,pc ; clean up stack and return to main EDIT routine +L8687 jsr LA171 ; get input from the generic input handler (will show the cursor) + cmpa #0x7f ; graphics (or DEL)? + bhs L8687 ; brif so - ignore it + cmpa #0x5f ; SHIFT-UP? + bne L8694 ; brif not + lda #0x1b ; replace with ESC +L8694 cmpa #0x0d ; carriage return? + beq L86A6 ; brif so (C=0) + cmpa #0x1b ; ESC + beq L86A6 ; brif so (C=0) + cmpa #0x08 ; backspace? + beq L86A6 ; brif so (C=0) + cmpa #32 ; control code? + blo L8687 ; brif control code - try again + orcc #1 ; set C for "valid" (printable) character +L86A6 rts +; TRON and TROFF commands +TRON skip1lda ; load flag with nonzero for trace enabled (and skip next) +TROFF clra ; clear flag for trace disabled + sta TRCFLG ; save trace status + rts +; POS function +POS lda DEVNUM ; get original device number + pshs a ; save it for later + jsr LA5AE ; fetch device number + jsr LA406 ; check for open file + jsr LA35F ; set up print parameters + ldb DEVPOS ; get current line position for the device + jmp LA5E4 ; return position in B as unsigned +; VARPTR function +VARPTRTOK jsr LB26A ; make sure we have ( + ldd ARYEND ; get address of end of arrays + pshs d ; save it + jsr LB357 ; parse variable descriptor + jsr LB267 ; make sure there is a ) + puls d ; get original end of arrays + exg x,d ; swap original end of arrays and the discovered variable pointer + cmpx ARYEND ; did array end move (variable created?) + bne L8724 ; brif so (FC error) + jmp GIVABF ; return the pointer (NOTE: as signed) +; MID$() assignment; note that this cannot make the string longer or shorter and if the replacement is shorter +; than the specified size, only the number of characters actually in the replacement will be used. +L86D6 jsr GETNCH ; eat the MID$ token + jsr LB26A ; force ( + jsr LB357 ; evaluate the variable + pshs x ; save variable descriptor + ldd 2,x ; point to start of original string + cmpd FRETOP ; is it in string space? + bls L86EB ; brif not + subd MEMSIZ ; is it still in string space (top end)? + bls L86FD ; brif so +L86EB ldb ,x ; get length of original string + jsr LB56D ; allocate space in string space + pshs x ; save pointer to string space + ldx 2,s ; get to original string descriptor + jsr LB643 ; move the string into string space + puls x,u ; get new string address and string descriptor + stx 2,u ; save new data address for the string + pshs u ; save descriptor address again +L86FD jsr LB738 ; evaluate ",start" + pshs b ; save start offset + tstb ; is start 0? + beq L8724 ; brif so - strings offsets are 1-based + ldb #255 ; default use the entire string + cmpa #') ; end of parameters? + beq L870E ; brif so + jsr LB738 ; evaluate ",length" +L870E pshs b ; save length + jsr LB267 ; make sure we have a ) + ldb #0xb3 ; make sure we have = + jsr LB26F + bsr L8748 ; evaluate replacement string + tfr x,u ; save replacement string address + ldx 2,s ; get original string descriptor + lda ,x ; get length of original string + suba 1,s ; subtract start position + bhs L8727 ; brif within the string - insert replacement +L8724 jmp LB44A ; raise illegal function call +L8727 inca ; A is now number of characters to the right of the position parameter + cmpa ,s ; compare to length desired + bhs L872E ; brif new length fits + sta ,s ; only use as much of the length as will fit +L872E lda 1,s ; get position offset + exg a,b ; swap replacement length and position + ldx 2,x ; point to original string address + decb ; we work with 0-based offsets + abx ; now X points to start of replacement + tsta ; replacing 0? + beq L8746 ; brif so - done + cmpa ,s ; is replacement shorter than the hole? + bls L873F ; brif so + lda ,s ; use copy the maximum number specified +L873F tfr a,b ; save number to move in B + exg u,x ; swap pointers so they are right for the routine + jsr LA59A ; copy string data +L8746 puls a,b,x,pc ; clean up stack and return +L8748 jsr LB156 ; evaluate expression + jmp LB654 ; make sure it's a string and return string details +; STRING$ function +STRING jsr LB26A ; make sure we have ( + jsr EVALEXPB ; evaluate repeat count (error if > 255) + pshs b ; save repeat count + jsr SYNCOMMA ; make sure there's a comma + jsr LB156 ; evaluate the thing to repeat + jsr LB267 ; make sure we have a ) + lda VALTYP ; is it string? + bne L8768 ; brif so + jsr LB70E ; get 8 bit character code + bra L876B ; use that +L8768 jsr LB6A4 ; get first character of string +L876B pshs b ; save repeat character + ldb 1,s ; get repeat count + jsr LB50F ; reserve space for the string + puls a,b ; get character and repeat count + beq L877B ; brif NULL string +L8776 sta ,x+ ; put character into string + decb ; put enough? + bne L8776 ; brif not +L877B jmp LB69B ; return the newly created string +; INSTR function +INSTR jsr LB26A ; evaluate ( + jsr LB156 ; evaluate first argument + ldb #1 ; default start position is 1 (start of string) + pshs b ; save start position + lda VALTYP ; get type of first argument + bne L879C ; brif string - use default starting position + jsr LB70E ; convert first argument into string offset + stb ,s ; save offset + beq L8724 ; brif starting at 0 - not allowed + jsr SYNCOMMA ; make sure there's a comma + jsr LB156 ; evaluate the search string + jsr LB146 ; make sure it *is* a string +L879C ldx FPA0+2 ; get search string descriptor + pshs x ; save it + jsr SYNCOMMA ; make sure we have a comma + jsr L8748 ; evalute the target string + pshs x,b ; save address and length of target string + jsr LB267 ; make sure we have a ) + ldx 3,s ; get search string address + jsr LB659 ; get string details + pshs b ; save search string length + cmpb 6,s ; compare length of search string to the start + blo L87D9 ; brif start position is beyond the search string - return 0 + lda 1,s ; get length of target string + beq L87D6 ; brif targetstring is NULL - match will be immediate + ldb 6,s ; get start position + decb ; zero-base it + abx ; now X points to the start position for the search +L87BE leay ,x ; point to start of search + ldu 2,s ; get target string pointer + ldb 1,s ; get targetlength + lda ,s ; get length of serach + suba 6,s ; see how much is left in searh + inca ; add one for "inclusivity" + cmpa 1,s ; do we have less than the target string? + blo L87D9 ; brif so - we obviously won't match +L87CD lda ,x+ ; compare a byte + cmpa ,u+ + bne L87DF ; brif no match + decb ; compared all of target? + bne L87CD ; brif not +L87D6 ldb 6,s ; get position where we matched + skip1 +L87D9 clrb ; flag no match + leas 7,s ; clean up stack + jmp LB4F3 ; return unsigned B +L87DF inc 6,s ; bump start position + leax 1,y ; move starting pointer + bra L87BE ; see if we match now +; Number parsing handler +XVEC19 cmpa #'& ; do we have & (hex or octal)? + bne L8845 ; brif not + leas 2,s ; we won't return to the original invoker +L87EB clr FPA0+2 ; clear bottom of FPA0 for 16 bit value + clr FPA0+3 + ldx #FPA0+2 ; point to accumulator + jsr GETNCH ; eat the & + cmpa #'O ; octal? + beq L880A ; brif so + cmpa #'H ; hex? + beq L881F ; brif so + jsr GETCCH ; reset flags on input + bra L880C ; go process octal (default) +L8800 cmpa #'8 ; is it a valid octal character? + lbhi LB277 ; brif not (BUG: should be LBHS or above be #'7) + ldb #3 ; base 8 multiplier + bsr L8834 ; add digit to accumulator +L880A jsr GETNCH ; get input character +L880C bcs L8800 ; brif numeric +L880E clr FPA0 ; clear upper bytes of FPA0 + clr FPA0+1 + clr VALTYP ; result is numeric + clr FPSBYT ; clear out any extra precision + clr FP0SGN ; make it positive + ldb #0xa0 ; exponent for integer aligned to right of FPA0 + stb FP0EXP + jmp LBA1C ; go normalize the result and return +L881F jsr GETNCH ; get input character + bcs L882E ; brif digit + jsr LB3A2 ; set carry if not alpha +L8826 bcs L880E ; brif not alpha + cmpa #'G ; is it valid HEX digit? + bhs L880E ; brif not + suba #7 ; normalize A-F to be just above 0-9 +L882E ldb #4 ; four bits per digit + bsr L8834 ; add digit to accumlator + bra L881F ; process another digit +L8834 asl 1,x ; shift accumulator one bit left + rol ,x + lbcs LBA92 ; brif too big - overflow + decb ; done enough bit shifts? + bne L8834 ; brif not +L883F suba #'0 ; remove ASCII bias + adda 1,x ; merge digit into accumlator (this cannot cause carry) + sta 1,x +L8845 rts +; Expression evaluation handler +XVEC15 puls u ; get back return address + clr VALTYP ; set result to numeric + ldx CHARAD ; save input pointer + jsr GETNCH ; get the input character + cmpa #'& ; HEX or OCTAL? + beq L87EB ; brif so + cmpa #0xcc ; FN? + beq L88B4 ; brif so - do "FNx()" + cmpa #0xff ; function token? + bne L8862 ; brif not + jsr GETNCH ; get function token value + cmpa #0x83 ; USR? + lbeq L892C ; brif so - short circuit Color Basic's USR handler +L8862 stx CHARAD ; restore input pointer + jmp ,u ; return to mainline code +L8866 ldx CURLIN ; are we in immediate mode? + leax 1,x + bne L8845 ; brif not - we're good + ldb #2*11 ; code for illegal direct statement +L886E jmp LAC46 ; raise error +; DEF command (DEF FN, DEF USR) +DEF ldx [CHARAD] ; get two input characters + cmpx #0xff83 ; USR? + lbeq L890F ; brif so - do DEF USR + bsr L88A1 ; get descriptor address for FN variable + bsr L8866 ; disallow DEF FN in immediate mode + jsr LB26A ; make sure we have ( + ldb #0x80 ; disallow arrays as arguments + stb ARYDIS + jsr LB357 ; evaluate variable + bsr L88B1 ; make sure it's numeric + jsr LB267 ; make sure we have ) + ldb #0xb3 ; make sure we have = + jsr LB26F + ldx V4B ; get variable descriptor address + ldd CHARAD ; get input pointer + std ,x ; save address of the actual function code in variable descriptor + ldd VARPTR ; get descriptor address of argument + std 2,x ; save argument descriptor address + jmp DATA ; move to the end of this statement +L88A1 ldb #0xcc ; make sure we have FN + jsr LB26F + ldb #0x80 ; disable array lookup + stb ARYDIS + ora #0x80 ; set bit 7 of first character (to indicate FN variable) + jsr LB35C ; find the variable + stx V4B ; save descriptor pointer +L88B1 jmp LB143 ; make sure we have a numeric variable +; Evaluate an FN call +L88B4 bsr L88A1 ; parse the FNx bit and get the descriptor + pshs x ; save descriptor + jsr LB262 ; evaluate parameter + bsr L88B1 ; make sure it's a number + puls u ; get FN descriptor + ldb #2*25 ; code for undefined function + ldx 2,u ; point to argument variable descriptor + beq L886E ; brif nothing doing there (if it was just created, this will be NULL) + ldy CHARAD ; save current input pointer + ldu ,u ; point to start of FN definition + stu CHARAD ; put input pointer there + lda 4,x ; save original value of argument and save it with current input, and variable pointers + pshs a + ldd ,x + ldu 2,x + pshs u,y,x,d + jsr LBC35 ; set argument variable to the argument +L88D9 jsr LB141 ; go evaluate the FN expression + puls d,x,y,u ; get back variable pointers, input pointer, and original variable value + std ,x + stu 2,x + puls a + sta 4,x + jsr GETCCH ; test end of FN formula + lbne LB277 ; brif not end of statement - problem with the function + sty CHARAD ; restore input pointer +L88EF rts +; Error handler +XVEC17 cmpb #2*25 ; is it a valid Extended Basic error code? + blo L88EF ; brif not - return to mainline + jsr LA7E9 ; turn off tape + jsr LA974 ; turn off sound + jsr LAD33 ; clean up stack and other bits + clr DEVNUM ; reset output to screen + jsr LB95C ; do a newline if needed + jsr LB9AF ; do a ? + ldx #L890B-25*2 ; point to error message table + jmp LAC60 ; go display error message +; Extended Basic error codes. Yes, NE is defined here even though it is only actually documented in the +; Disk Basic documentation. It is here for the use of DLOAD. +L890B fcc 'UF' ; 25 undefined function call + fcc 'NE' ; 26 File not found +; DEF USR +L890F jsr GETNCH ; eat the USR token + bsr L891C ; get pointer to USR call + pshs x ; save FN exec address location + bsr L8944 ; calculate execution address + puls u ; get FN address pointer + stx ,u ; save new address + rts +L891C clrb ; default routine number is 0 + jsr GETNCH ; fetch the call number + bcc L8927 ; brif not a number + suba #'0 ; remove ASCII bias + tfr a,b ; save it in the right place + jsr GETNCH ; eat the call number +L8927 ldx USRADR ; get start address of USR jump table + aslb ; two bytes per address + abx ; now X points to the right entry + rts +; Evaluate a USR call +L892C bsr L891C ; find the correct routine address location + ldx ,x ; get routine address + pshs x ; save it + jsr LB262 ; evaluate argument + ldx #FP0EXP ; point to FPA0 (argument value) + lda VALTYP ; is it string? + beq L8943 ; brif not + jsr LB657 ; fetch string details (removes it from the string stack) + ldx FPA0+2 ; get string descriptor pointer + lda VALTYP ; set flags for the value type +L8943 rts ; call the routine and return to mainline code +L8944 ldb #0xb3 ; check for "=" + jsr LB26F + jmp LB73D ; evaluate integer expression to X and return +; Extended Basic IRQ handler +XIRQSV lda PIA0+3 ; is it VSYNC interrupt? + bmi L8952 ; brif so + rti ; really should clear the HSYNC interrupt here +L8952 lda PIA0+2 ; clear VSYNC interrupt + ldx TIMVAL ; increment the TIMER value + leax 1,x + stx TIMVAL + jmp L9C3E ; check for other stuff +; TIMER= +L8960 jsr GETNCH ; eat the TIMER token + bsr L8944 ; evaluate =nnnn to X + stx TIMVAL ; set the timer + rts +; TIMER function +TIMER ldx TIMVAL ; get timer value + stx FPA0+2 ; set it in FPA0 + jmp L880E ; return as positive 16 bit value +; DEL command +DEL lbeq LB44A ; raise error if no argument (probably to avoid accidentally deleting line 0) + jsr LAF67 ; parse line number + jsr LAD01 ; find line + stx VD3 ; save address of line + jsr GETCCH ; is there something more? + beq L8990 ; brif not + cmpa #0xac ; dash? + bne L89BF ; brif not - error out + jsr GETNCH ; each the - + beq L898C ; brif no ending line - use default line number + bsr L89AE ; parse second line number and save in BINVAL + bra L8990 ; do the deletion +L898C lda #0xff ; set to maximum line number + sta BINVAL +L8990 ldu VD3 ; point end to start + skip2 +L8993 ldu ,u ; point to start of next line + ldd ,u ; check for end of program + beq L899F ; brif end of program + ldd 2,u ; get line number + subd BINVAL ; is it in range? + bls L8993 ; brif so +L899F ldx VD3 ; get starting line address + bsr L89B8 ; close up gap + jsr LAD21 ; reset input pointer and erase variables + ldx VD3 ; get start of program after the deletion + jsr LACF1 ; recompute netl ine pointers + jmp LAC73 ; return to immediate mode +L89AE jsr LAF67 ; parse a line number + jmp LA5C7 ; make sure there's nothing more +L89B4 lda ,u+ ; copy a byte + sta ,x+ +L89B8 cmpu VARTAB ; end of program? + bne L89B4 ; brif not + stx VARTAB ; save new start of variables/end of program +L89BF rts +; LINE INPUT +L89C0 jsr L8866 ; raise error if in immediate mode + jsr GETNCH ; eat the "INPUT" token + cmpa #'# ; device number? + bne L89D2 ; brif not + jsr LA5A5 ; parse device number + jsr LA3ED ; make sure it's valid for input + jsr SYNCOMMA ; make sure there's a comma after the device number +L89D2 cmpa #'" ; is there a prompt? + bne L89E1 ; brif not + jsr LB244 ; parse the string + ldb #'; ; make sure there's a semicolon after the prompt + jsr LB26F + jsr LB99F ; go actually display the prompt +L89E1 leas -2,s ; make a hole on the stack (so number of return adddresses is right) + jsr LB035 ; read an input line from current device + leas 2,s ; clean up stack + clr DEVNUM ; reset to screen/keyboard + jsr LB357 ; parse a variable + stx VARDES ; save pointer to it + jsr LB146 ; make sure it's a string + ldx #LINBUF ; point to input buffer + clra ; make sure we terminate on NUL only + jsr LB51A ; parse string and store it in string space + jmp LAFA4 ; go assign the string to its final resting place +; RENUM command +L89FC jsr LAF67 ; read a line number + ldx BINVAL ; get value + rts +L8A02 ldx VD1 ; get current old number being renumbered +L8A04 stx BINVAL ; save number being searched for + jmp LAD01 ; go find line number +RENUM jsr LAD26 ; erase variables + ldd #10 ; default line number interval and start + std VD5 ; set starting line number + std VCF ; set number interval + clrb ; now D is 0 + std VD1 ; save default start for renumbering + jsr GETCCH ; are there any arguments + bcc L8A20 ; brif not numeric + bsr L89FC ; fetch line number + stx VD5 ; save line beginning number + jsr GETCCH ; get input character +L8A20 beq L8A3D ; brif end of line + jsr SYNCOMMA ; make sure we have a comma + bcc L8A2D ; brif next isn't numeric + bsr L89FC ; fetch starting line number + stx VD1 ; save the number where we start working + jsr GETCCH ; fetch input character +L8A2D beq L8A3D ; brif end of line + jsr SYNCOMMA ; make sure we have a comma + bcc L8A3A ; brif we don't have a number + bsr L89FC ; parse the number + stx VCF ; save interval + beq L8A83 ; brif we ave a zero interval +L8A3A jsr LA5C7 ; raise error if more stuff +L8A3D bsr L8A02 ; get address of old number to process + stx VD3 ; save address + ldx VD5 ; get the next renumbered line to use + bsr L8A04 ; find that line + cmpx VD3 ; is it before the previous one? + blo L8A83 ; brif so - raise error + bsr L8A67 ; make sure renumbered line numbers will be in range + jsr L8ADD ; convert line numbers to "expanded" binary + jsr LACEF ; recalculate next line pointers + bsr L8A02 ; get address of first line to renumber + stx VD3 ; save it + bsr L8A91 ; make sure line numbers exist + bsr L8A68 ; renumber the actual lines + bsr L8A91 ; update line numbers in program text + jsr L8B7B ; convert packed binary line numbers to text + jsr LAD26 ; erase variables, reset stack, etc. + jsr LACEF ; recalculate next line pointers + jmp LAC73 ; bounce back to immediate mode +L8A67 skip1lda ; set line number flag to nonzero (skip next instruction) +L8A68 clra ; set line number flag to zero (insert new numbers) + sta VD8 ; save line number flag + ldx VD3 ; get address of line being renumbered + ldd VD5 ; get the current renumbering number + bsr L8A86 ; return if end of program +L8A71 tst VD8 ; test line number flag + bne L8A77 ; brif not adding new numbers + std 2,x ; set new number +L8A77 ldx ,x ; point to next line + bsr L8A86 ; return if end of program + addd VCF ; add interval to current number + bcs L8A83 ; brif we overflowed - bad line number + cmpa #MAXLIN ; maximum legal number? + blo L8A71 ; brif so - do another +L8A83 jmp LB44A ; raise FC error +L8A86 pshs d ; save D (we're going to clobber it) + ldd ,x ; get next line pointer + puls d ; unclobber D + bne L8A90 ; brif not end of program + leas 2,s ; return to caller's caller +L8A90 rts +L8A91 ldx TXTTAB ; get start of program + leax -1,x ; move pointer back one (compensate for leax 1,x below) +L8A95 leax 1,x ; move to next line + bsr L8A86 ; return if end of program +L8A99 leax 3,x ; move past next line address and line number, go one before line +L8A9B leax 1,x ; move to next character + lda ,x ; check input character + beq L8A95 ; brif end of line + stx TEMPTR ; save current pointer + deca ; is it start of packed numeric line number? + beq L8AB2 ; brif so + deca ; does line exist? + beq L8AD3 ; brif line number exists + deca ; not part of something to process? + bne L8A9B ; brif so +L8AAC lda #3 ; set 1st byte to 3 to indicate line number not existing + sta ,x+ + bra L8A99 ; go process another +L8AB2 ldd 1,x ; get MSB of line number + dec 2,x ; is MS byte zero? + beq L8AB9 ; brif not + clra ; set MS byte to 0 +L8AB9 ldb 3,x ; get LSB of line number + dec 4,x ; is it zero? + beq L8AC0 ; brif not + clrb ; clear byte +L8AC0 std 1,x ; save binary number + std BINVAL ; save trial number + jsr LAD01 ; find the line number +L8AC7 ldx TEMPTR ; get start of packed line + bcs L8AAC ; brif line number not found + ldd V47 ; get address of line number + inc ,x+ ; bump first byte to 2 (exists if checking) or 1 if inserting + std ,x ; save address of correct number + bra L8A99 ; go process more +L8AD3 clr ,x ; clear carry and first byte + ldx 1,x ; point to address of correct line + ldx 2,x ; get correct line number + stx V47 ; save it + bra L8AC7 ; insert into line +L8ADD ldx TXTTAB ; get beginning of program + bra L8AE5 +L8AE1 ldx CHARAD ; get input pointer + leax 1,x ; move it forward +L8AE5 bsr L8A86 ; return if end of program + leax 2,x ; move past line address +L8AE9 leax 1,x ; move forward +L8AEB stx CHARAD ; save input pointer +L8AED jsr GETNCH ; get an input character +L8AEF tsta ; is it actual 0? + beq L8AE1 ; brif end of line + bpl L8AED ; brif not a token + ldx CHARAD ; get input pointer + cmpa #0xff ; function? + beq L8AE9 ; brif so - ignore it (and following byte) + jsr RVEC22 ; do the RAM hook thing + cmpa #0xa7 ; THEN? + beq L8B13 ; brif so + cmpa #0x84 ; ELSE? + beq L8B13 ; brif so + cmpa #0x81 ; GO(TO|SUB)? + bne L8AED ; brif not - we don't have a line number + jsr GETNCH ; get TO/SUB + cmpa #0xa5 ; GOTO? + beq L8B13 ; brif so + cmpa #0xa6 ; GOSUB? + bne L8AEB ; brif not +L8B13 jsr GETNCH ; fetch character after token + bcs L8B1B ; brif numeric (line number) +L8B17 jsr GETCCH ; set flags on input character + bra L8AEF ; keep checking for line numbers +L8B1B ldx CHARAD ; get input pointer + pshs x ; save it + jsr LAF67 ; parse line number + ldx CHARAD ; get input pointer after line +L8B24 lda ,-x ; get character before pointer + jsr L90AA ; set C if numeric + bcs L8B24 ; brif not numeric + leax 1,x ; move pointer up + tfr x,d ; calculate size of line number + subb 1,s + subb #5 ; make sure at least 5 bytes + beq L8B55 ; brif exactly 5 bytes - no change + blo L8B41 ; brif less than 5 bytes + leau ,x ; move remainder of program backward + negb ; negate extra number of bytes (to subtract from X) + leax b,x ; now X is the correct position to move program to + jsr L89B8 ; shift program backward + bra L8B55 +L8B41 stx V47 ; save end of line number space (end of copy) + ldx VARTAB ; get end of program + stx V43 ; set source pointer + negb ; get positive difference + leax b,x ; now X is the top of the destination block + stx V41 ; set copy destination + stx VARTAB ; save new end of program + jsr LAC1E ; make sure enough room and make a hole in the program + ldx V45 ; get end address of destination block + stx CHARAD ; set input there +L8B55 puls x ; get starting address of the line number + lda #1 ; set "new number" flag + sta ,x + sta 2,x + sta 4,x + ldb BINVAL ; get MS byte of line number + bne L8B67 ; brif it is not zero + ldb #1 ; set to 1 if MSB is 0 + inc 2,x ; flag MSB as 0 +L8B67 stb 1,x ; set MSB of line number + ldb BINVAL+1 ; get LSB of number + bne L8B71 ; brif nonzero + ldb #1 ; set to 1 if LSB is 0 + inc 4,x ; flag LSB as 0 +L8B71 stb 3,x ; save LSB of line number + jsr GETCCH ; get input character + cmpa #', ; multiple line numbers? (ON GOTO, ON GOSUB) + beq L8B13 ; brif so - process another + bra L8B17 ; go look for more line numbers +L8B7B ldx TXTTAB ; point to start of program + leax -1,x ; move back (compensate for inc below) +L8B7F leax 1,x ; move forward + ldd 2,x ; get this line number + std CURLIN ; save it (for error message) + jsr L8A86 ; return if end of program + leax 3,x ; skip address and line number, stay one before line text +L8B8A leax 1,x ; move to next character +L8B8C lda ,x ; get input character + beq L8B7F ; brif end of line + deca ; valid line new line number? + beq L8BAE ; brif so + suba #2 ; undefined line? + bne L8B8A ; brif not + pshs x ; save line number pointer + ldx #L8BD9-1 ; show UL message + jsr STRINOUT + ldx ,s ; get input pointer + ldd 1,x ; get undefined line number + jsr LBDCC ; display line number + jsr LBDC5 ; print out "IN XXXX" + jsr LB958 ; do a newline + puls x ; get input pointer back +L8BAE pshs x ; save input pointer + ldd 1,x ; get binary value of line number + std FPA0+2 ; save it in FPA0 + jsr L880E ; adjust FPA0 as integer + jsr LBDD9 ; convert to text string + puls u ; get previous input pointer address + ldb #5 ; each expanded line uses 5 bytes +L8BBE leax 1,x ; move pointer forward (in string number) past sign + lda ,x ; do we have a digit? + beq L8BC9 ; brif not - end of number + decb ; mark a byte consumed + sta ,u+ ; put digit in program + bra L8BBE ; copy another digit +L8BC9 leax ,u ; point to address at end of text number + tstb ; did number fill whole space? + beq L8B8C ; brif so - move on + leay ,u ; save end of number pointer + leau b,u ; point to the end of the original expanded number + jsr L89B8 ; close up gap in program + leax ,y ; get end of line number pointer back + bra L8B8C ; go process more +L8BD9 fcn 'UL ' +; HEX$ function +HEXDOL jsr LB740 ; convert argument to positive integer + ldx #STRBUF+2 ; point to string buffer + ldb #4 ; convert 4 nibbles +L8BE5 pshs b ; save nibble counter + clrb ; clear digit accumulator + lda #4 ; do 4 shifts +L8BEA asl FPA0+3 ; shift a bit off the left of the value into low bits of B + rol FPA0+2 + rolb + deca ; done all shifts? + bne L8BEA ; brif not + tstb ; do we have a nonzero digit? + bne L8BFF ; brif so + lda ,s ; is it last digit? + deca + beq L8BFF ; brif so - keep the 0 + cmpx #STRBUF+2 ; is it a middle zero? + beq L8C0B ; brif not +L8BFF addb #'0 ; add ASCII bias + cmpb #'9 ; above 9? + bls L8C07 ; brif not + addb #7 ; adjust into alpha range +L8C07 stb ,x+ ; save digit in output + clr ,x ; make sure we have a NUL term +L8C0B puls b ; get back nibble counter + decb ; done all? + bne L8BE5 ; brif not + leas 2,s ; don't return mainline (we're returning a string) + ldx #STRBUF+1 ; point to start of converted number + jmp LB518 ; save string in string space, etc., and return it +; DLOAD command +DLOAD jsr LA429 ; close files +L8C1B clr ,-s ; save default token (not DLOADM) + cmpa #'M ; is it DLOADM? + bne L8C25 ; brif not + sta ,s ; save the "M" + jsr GETNCH ; eat the "M" +L8C25 jsr LA578 ; parse the file name + jsr GETCCH ; get character after file name + beq L8C44 ; brif end of line + jsr SYNCOMMA ; make sure we have a comma + cmpa #', ; do we have 2 commas? + beq L8C44 ; brif so - use default baud rate + jsr EVALEXPB ; evaluate baud rate +L8C36 lda #44*4 ; delay for 300 baud + tstb ; was argument 0? + beq L8C42 ; brif so - 300 baud + lda #44 ; constant for 1200 baud + decb ; was it 1? + lbne LB44A ; raise error if not +L8C42 sta DLBAUD ; save baud rate constant +L8C44 jsr L8CD0 ; transmit file name and read in file status + pshs a ; save register + lda #-3 ; set input to DLOAD + sta DEVNUM + puls a ; restore register + tst ,s+ ; is it DLOADM? + bne L8C85 ; brif so + jsr LA5C7 ; check for end of line - error if not + tstb ; ASCII? + beq L8C5F ; brif not - do error + jsr LAD19 ; clear out program + jmp LAC7C ; go read program +L8C5F jmp LA616 ; raise bad file mode +; CLOADM patch for Extended Basic +L8C62 jsr GETNCH ; get character after CLOAD + cmpa #'M ; CLOADM? + lbne CLOAD ; brif not - Color Basic's CLOAD can handle it + clr FILSTA ; close tape file + jsr GETNCH ; eat the "M" + jsr LA578 ; parse file name + jsr LA648 ; find the file + tst CASBUF+10 ; is it a chunked file? + lbeq LA505 ; brif not - Color Basic's CLOADM can handle it + ldu CASBUF+8 ; get file type and ASCII flag + dec DEVNUM ; set source device to tape + jsr LA635 ; go read the first block + tfr u,d ; put type and ASCII flag somewhere more useful +; NOTE: DLOADM comes here to do the final processing +L8C85 subd #0x200 ; is it binary and "machine language"? + bne L8C5F ; brif not - raise an error + ldx ZERO ; default load offset + jsr GETCCH ; is there any offset? + beq L8C96 ; brif not + jsr SYNCOMMA ; make sure there's a comma + jsr LB73D ; evaluate offset in X +L8C96 stx VD3 ; save offset + jsr LA5C7 ; raise error if more stuff follows +L8C9B bsr L8CC6 ; get type of "amble" + pshs a ; save it + bsr L8CBF ; read in block length + tfr d,y ; save it + bsr L8CBF ; read in load address + addd VD3 ; add in offset + std EXECJP ; save it as the execution address + tfr d,x ; put load address in a pointer + lda ,s+ ; get "amble" type + lbne LA42D ; brif postamble - close file +L8CB1 bsr L8CC6 ; read a data byte + sta ,x ; save in memory + cmpa ,x+ ; did it actually save? + bne L8CCD ; brif not RAM - raise error + leay -1,y ; done yet? + bne L8CB1 ; brif not + bra L8C9B ; look for another "amble" +L8CBF bsr L8CC1 ; read a character to B +L8CC1 bsr L8CC6 ; read character to A + exg a,b ; swap character with previously read one +L8CC5 rts +L8CC6 jsr LA176 ; read a character from input + tst CINBFL ; EOF? + beq L8CC5 ; brif not +L8CCD jmp LA619 ; raise I/O error if EOF +L8CD0 bsr L8D14 ; transmit file name + pshs b,a ; save file status + inca ; was file found? + beq L8CDD ; brif not + ldu ZERO ; zero U - first block + bsr L8CE4 ; read block + puls a,b,pc ; restore status and return +L8CDD ldb #2*26 ; code for NE error + jmp LAC46 ; raise error +L8CE2 ldu CBUFAD ; get block number +L8CE4 leax 1,u ; bump block number + stx CBUFAD ; save new block number + ldx #CASBUF ; use cassette buffer + jsr L8D7C ; read a block + jmp LA644 ; reset input buffer pointers +; Generic input handler for Extended Basic +XVEC4 lda DEVNUM ; get device number + cmpa #-3 ; DLOAD? + bne L8D01 ; brif not + leas 2,s ; don't return to mainline code + clr CINBFL ; reset EOF flag to not EOF + tst CINCTR ; anything available? + bne L8D02 ; brif so - fetch one + com CINBFL ; flag EOF +L8D01 rts +L8D02 pshs u,y,x,b ; save registers + ldx CINPTR ; get buffer pointer + lda ,x+ ; get character from buffer + pshs a ; save it for return + stx CINPTR ; save new input pointer + dec CINCTR ; account for byte removed from buffer + bne L8D12 ; brif buffer not empty + bsr L8CE2 ; go read a block +L8D12 puls a,b,x,y,u,pc ; restore registers, return value, and return +L8D14 clra ; clear attempt counter + pshs x,b,a ; make a hole for variables + leay ,s ; set up frame pointer + bra L8D1D ; go read block +L8D1B bsr L8D48 ; bump attempt counter +L8D1D lda #0x8a ; send file request control code + bsr L8D58 + bne L8D1B ; brif no echo or error + ldx #CFNBUF+1 ; point to file name +L8D26 lda ,x+ ; get file name characater + jsr L8E04 ; send it + cmpx #CFNBUF+9 ; end of file name? + bne L8D26 ; brif not + bsr L8D62 ; output check byte and look for response + bne L8D1B ; transmit name again if not ack + bsr L8D72 ; get file type (0xff is not found) + bne L8D1B ; brif error + sta 2,y ; save file type + bsr L8D72 ; read ASCII flag + bne L8D1B ; brif error + sta 3,y ; save ASCII flag + bsr L8D6B ; read check byte + bne L8D1B ; brif error + leas 2,s ; lose attempt counter and check byte + puls a,b,pc ; return file type and ascii flag +L8D48 inc ,y ; bump attempt counter + lda ,y ; get new count + cmpa #5 ; done 5 times? + blo L8D6A ; brif not + lda #0xbc ; send abort code + jsr L8E0C + jmp LA619 ; raise an I/O error +L8D58 pshs a ; save compare character + bsr L8DB8 ; send character + bne L8D60 ; brif read error + cmpa ,s ; does it match? (set Z if good) +L8D60 puls a,pc ; restore character and return +L8D62 lda 1,y ; get XOR check byte + bsr L8DB8 ; send it and read + bne L8D6A ; brif read error + cmpa #0xc8 ; is it ack? (set Z if so) +L8D6A rts +L8D6B bsr L8D72 ; read character from rs232 + bne L8D6A ; brif error + lda 1,y ; get check byte + rts +L8D72 bsr L8DBC ; read a character from rs232 + pshs a,cc ; save result (and flags) + eora 1,y ; accumulate xor checksum + sta 1,y + puls cc,a,pc ; restore byte, flags, and return +L8D7C clra ; reset attempt counter + pshs u,y,x,b,a ; make a stack frame + asl 7,s ; split block number into two 7 bit chuncks + rol 6,s + lsr 7,s + leay ,s ; set up frame pointer + bra L8D8B +L8D89 bsr L8D48 ; bump attempt counter +L8D8B lda #0x97 ; send block request code + bsr L8D58 + bne L8D89 ; brif error + lda 6,y ; send out block number (high bits first) + bsr L8E04 + lda 7,y + bsr L8E04 + bsr L8D62 ; send check byte and get ack + bne L8D89 ; brif error + bsr L8D72 ; read block size + bne L8D89 ; brif read error + sta 4,y ; save character count + ldx 2,y ; get buffer pointer + ldb #128 ; length of data block +L8DA7 bsr L8D72 ; read a data byte + bne L8D89 ; brif error + sta ,x+ ; save byte in buffer + decb ; done a whole block? + bne L8DA7 ; brif not + bsr L8D6B ; read check byte + bne L8D89 ; brif error + leas 4,s ; lose attempt counter, check byte, and buffer pointer + puls a,b,x,pc ; return with character count in A, clean rest of stack +L8DB8 clr 1,y ; clear check byte + bsr L8E0C ; output character +L8DBC clra ; clear attempt counter + pshs x,b,cc ; save registers and interrupt status + orcc #0x50 ; disable interrupts + lda TIMOUT ; get timout delay (variable) + ldx ZERO ; get constant timeout value +L8DC5 bsr L8DE6 ; get RS232 status + bcc L8DC5 ; brif "space" - waiting for "mark" +L8DC9 bsr L8DE6 ; get RS232 status + bcs L8DC9 ; brif "mark" - waiting for "space" (start bit) + bsr L8DF9 ; delay for half of bit time + ldb #1 ; set bit probe + pshs b ; save it + clra ; reset data byte +L8DD4 bsr L8DF7 ; wait one bit time + ldb PIA1+2 ; get input bit to carry + rorb + bcc L8DDE ; brif "space" (0) + ora ,s ; merge bit probe in +L8DDE asl ,s ; shift bit probe over + bcc L8DD4 ; brif we haven't done 8 bits + leas 1,s ; remove bit probe + puls cc,b,x,pc ; restore interrupts, registers, and return +L8DE6 ldb PIA1+2 ; get RS232 value + rorb ; put in C + leax 1,x ; bump timeout + bne L8DF6 ; brif nonzero + deca ; did the number of waits expire? + bne L8DF6 ; brif not + leas 2,s ; don't return - we timed out + puls cc,b,x ; restore interrupts and registers + inca ; clear Z (A was zero above) +L8DF6 rts +L8DF7 bsr L8DF9 ; do first half of bit delay then fall through for second +L8DF9 pshs a ; save register + lda DLBAUD ; get baud rate constant +L8DFD brn L8DFD ; do nothing - delay + deca ; time expired? + bne L8DFD ; brif not + puls a,pc ; restore register and return +L8E04 pshs a ; save character to send + eora 1,y ; accumulate chechsum + sta 1,y + puls a ; get character back +L8E0C pshs b,a,cc ; save registers and interrupt status + orcc #0x50 ; disable interrupts + bsr L8DF7 ; do a bit delay + bsr L8DF7 ; do another bit delay + clr PIA1 ; set output to space (start bit) + bsr L8DF7 ; do a bit delay + ldb #1 ; bit probe start at LSB + pshs b ; save bitprobe +L8E1D lda 2,s ; get output byte + anda ,s ; see what our current bit is + beq L8E25 ; brif output is 0 + lda #2 ; set output to "marking" +L8E25 sta PIA1 ; send bit + bsr L8DF7 ; do a bit delay + asl ,s ; shift bit probe + bcc L8E1D ; brif not last bit + lda #2 ; set output to marking ("stop" bit) + sta PIA1 + leas 1,s ; lose bit probe + puls cc,a,b,pc ; restore registers, interrupts, and return +; PRINT USING +; This is a massive block of code for something that has limited utility. It is *almost* flexible enough to +; be truly useful outside of a narrow range of use cases. Indeed, this comes in at about 1/8 of the total +; Extended Color Basic ROM. +; +; This uses several variables: +; VD5: pointer to format string descriptor +; VD7: next print item flag +; VD8: right digit counter +; VD9: left digit counter (or length of string argument) +; VDA: status byte (bits as follows): +; 6: force comma +; 5: force leading * +; 4: floating $ +; 3: pre-sign +; 2: post-sign +; 0: scientific notation +L8E37 lda #1 ; set length to use to 1 + sta VD9 +L8E3B decb ; consume character from format string + jsr L8FD8 ; show error flag if flags set + jsr GETCCH ; get input character + lbeq L8ED8 ; brif end of line - bail + stb VD3 ; save remaining string length + jsr LB156 ; evaluate the argument + jsr LB146 ; error if numeric + ldx FPA0+2 ; get descriptor for argument + stx V4D ; save it for later + ldb VD9 ; get length counter to use + jsr LB6AD ; get B bytes of string space (do a LEFT$) + jsr LB99F ; print the formatted string + ldx FPA0+2 ; get formatted string descriptor + ldb VD9 ; get requested length + subb ,x ; see if we have any left over +L8E5F decb ; have we got the right width? + lbmi L8FB3 ; brif so - go process more + jsr LB9AC ; output a space + bra L8E5F ; go see if we're done yet +L8E69 stb VD3 ; save current format string counter and pointer + stx TEMPTR + lda #2 ; initial spaces count = 2 (for the two %s) + sta VD9 ; save length counter +L8E71 lda ,x ; get character in string + cmpa #'% ; is it the end of the sequence? + beq L8E3B ; brif so - display requested part of the strign + cmpa #0x20 ; space? + bne L8E82 ; brif not + inc VD9 ; bump spaces count + leax 1,x ; move format pointer forward + decb ; consume character + bne L8E71 ; brif not end of format string +L8E82 ldx TEMPTR ; restore format string pointer + ldb VD3 ; get back format string length + lda #'% ; show % as debugging aid +L8E88 jsr L8FD8 ; send error indicator if flags set + jsr PUTCHR ; output character + bra L8EB9 ; go process more format string +; PRINT extension for USING +XVEC9 cmpa #0xcd ; USING? + beq L8E95 ; brif so + rts ; return to mainline code +; This is the main entry point for PRINT USING +L8E95 leas 2,s ; don't return to the mainline code + jsr LB158 ; evaluate the format string + jsr LB146 ; error if numeric + ldb #'; ; make sure there's a ; after the string + jsr LB26F + ldx FPA0+2 ; get format string descriptor + stx VD5 ; save it for later + bra L8EAE ; process format string +L8EA8 lda VD7 ; is there a print item? + beq L8EB4 ; brif not + ldx VD5 ; get back format string descriptor +L8EAE clr VD7 ; reset next print item flag + ldb ,x ; get length of format string + bne L8EB7 ; brif string is non-null +L8EB4 jmp LB44A ; raise FC error +L8EB7 ldx 2,x ; point to start of string +L8EB9 clr VDA ; clear status (new item) +L8EBB clr VD9 ; clear left digit counter + lda ,x+ ; get character from format string + cmpa #'! ; ! (use first character of string)? + lbeq L8E37 ; brif so + cmpa #'# ; digit? + beq L8F24 ; brif so - handle numeric + decb ; consume format character + bne L8EE2 ; brif not done + jsr L8FD8 ; show a "+" if any flags set - indicates error at end of string + jsr PUTCHR ; output format string character +L8ED2 jsr GETCCH ; get current input character + bne L8EA8 ; brif not end of statement + lda VD7 ; get next item flag +L8ED8 bne L8EDD ; brif more print items + jsr LB958 ; do newline +L8EDD ldx VD5 ; point to format string descriptor + jmp LB659 ; remove from string stack, etc., if appropriate (and return) +L8EE2 cmpa #'+ ; is it + (pre-sign)? + bne L8EEF ; brif not + jsr L8FD8 ; send a "+" if flags set + lda #8 ; flag for pre-sign + sta VDA ; set flags + bra L8EBB ; go interpret some more stuff +L8EEF cmpa #'. ; decimal? + beq L8F41 ; brif so - numeric + cmpa #'% ; % (show string)? + lbeq L8E69 ; brif so + cmpa ,x ; do we have two identical characters? +L8EFB bne L8E88 ; brif not - invalid format character + cmpa #'$ ; double $? + beq L8F1A ; brif so - floating $ + cmpa #'* ; double *? + bne L8EFB ; brif not + lda VDA ; get status byte + ora #0x20 ; enable * padding + sta VDA + cmpb #2 ; is $$ the last two? + blo L8F20 ; brif so + lda 1,x ; is it $ after? + cmpa #'$ + bne L8F20 ; brif not + decb ; consume the "$" + leax 1,x + inc VD9 ; add to digit counter * pad + $ counter +L8F1A lda VDA ; indicate floating $ + ora #0x10 + sta VDA +L8F20 leax 1,x ; consume the second format character + inc VD9 ; add one more left place +L8F24 clr VD8 ; clear right digit counter +L8F26 inc VD9 ; bump left digit counter + decb ; consume character + beq L8F74 ; brif end of string + lda ,x+ ; get next format character + cmpa #'. ; decimal? + beq L8F4F ; brif so + cmpa #'# ; digit? + beq L8F26 ; brif so + cmpa #', ; comma flag? + bne L8F5A ; brif not + lda VDA ; set commas flag + ora #0x40 + sta VDA + bra L8F26 ; handle more characters to left of decimal +L8F41 lda ,x ; get character after . + cmpa #'# ; digit? + lbne L8E88 ; brif not - invalid + lda #1 ; set right digit counter to 1 (for the .) + sta VD8 + leax 1,x ; consume the . +L8F4F inc VD8 ; add one to right digit counter + decb ; consume character + beq L8F74 ; brif end of format string + lda ,x+ ; get another format character + cmpa #'# ; digit? + beq L8F4F ; brif so +L8F5A cmpa #0x5e ; up arrow? + bne L8F74 ; brif not + cmpa ,x ; two of them? + bne L8F74 ; brif not + cmpa 1,x ; three of them? + bne L8F74 ; brif not + cmpa 2,x ; four of them? + bne L8F74 ; brif not + cmpb #4 ; string actually has the characters? + blo L8F74 ; brif not + subb #4 ; consome them + leax 4,x + inc VDA ; set scientific notation bit +L8F74 leax -1,x ; back up input pointer + inc VD9 ; add one digit for pre-sign force + lda VDA ; is it pre-sign? + bita #8 + bne L8F96 ; brif so + dec VD9 ; undo pre-sign adjustment + tstb ; end of string? + beq L8F96 ; brif so + lda ,x ; get next character + suba #'- ; post sign force? + beq L8F8F ; brif so + cmpa #'+-'- ; plus? + bne L8F96 ; brif not + lda #8 ; trailing + is a pre-sign force +L8F8F ora #4 ; add in post sign flag + ora VDA ; merge with flags + sta VDA + decb ; consume character +L8F96 jsr GETCCH ; do we have an argument + lbeq L8ED8 ; brif not + stb VD3 ; save format string length + jsr LB141 ; evluate numeric expression + lda VD9 ; get left digit counter + adda VD8 ; add in right digit counter + cmpa #17 ; is it more than 16 digits + decimal? + lbhi LB44A ; brif so - this is a problem + jsr L8FE5 ; format value according to settings + leax -1,x ; move buffer pointer back + jsr STRINOUT ; display formatted number string +L8FB3 clr VD7 ; reset next print item flag + jsr GETCCH ; get current input character + beq L8FC6 ; brif end of statement + sta VD7 ; set next print flag to nonzero + cmpa #'; ; list separator ;? + beq L8FC4 ; brif so + jsr SYNCOMMA ; require a comma between if not ; + bra L8FC6 ; process next item +L8FC4 jsr GETNCH ; munch the semicolon +L8FC6 ldx VD5 ; get format string descriptor + ldb ,x ; get length of string + subb VD3 ; subtract amount left after last item + ldx 2,x ; point to string address + abx ; move pointer to correct spot + ldb VD3 ; get remaining string length + lbne L8EB9 ; if we have more, interpret from there + jmp L8ED2 ; re-interpret from start if we hit the end +L8FD8 pshs a ; save character + lda #'+ ; "error" flag character + tst VDA ; did we have some flags set? + beq L8FE3 ; brif not + jsr PUTCHR ; output error flag +L8FE3 puls a,pc ; restore character and return +L8FE5 ldu #STRBUF+4 ; point to string buffer + ldb #0x20 ; blank space + lda VDA ; get flags + bita #8 ; pre-sign? + beq L8FF2 ; brif not + ldb #'+ ; plus sign +L8FF2 tst FP0SGN ; get sign of value + bpl L8FFA ; brif positive + clr FP0SGN ; make number positive (for later) + ldb #'- ; negative sign +L8FFA stb ,u+ ; put sign in buffer + ldb #'0 ; put a zero there + stb ,u+ + anda #1 ; check scientific notation force + lbne L910D ; brif so + ldx #LBDC0 ; point to FP 1E+9 + jsr LBCA0 ; is it less? + bmi L9023 ; brif so + jsr LBDD9 ; convert FP number to string (we're doing scientific notation) +L9011 lda ,x+ ; advance pointer to end of string + bne L9011 +L9015 lda ,-x ; make a hole at the start + sta 1,x + cmpx #STRBUF+3 ; done yet? + bne L9015 ; brif not + lda #'% ; put "overflow" flag at start + sta ,x + rts +L9023 lda FP0EXP ; get exponent of value + sta V47 ; save it + beq L902C ; brif value is 0 + jsr L91CD ; convert to number with 9 significant figures to left of decimal +L902C lda V47 ; get base 10 exponent offset + lbmi L90B3 ; brif < 100,000,000 + nega ; get negative difference + adda VD9 ; add to number of left digits + suba #9 ; account for the 9 we actually have + jsr L90EA ; put leading zeroes in buffer + jsr L9263 ; initialize the decimal point and comma counters + jsr L9202 ; convert FPA0 to decimal ASCII in buffer + lda V47 ; get base 10 exponent + jsr L9281 ; put that many zeroes in buffer, stop at decimal point + lda V47 ; get base 10 exponent + jsr L9249 ; check for decimal + lda VD8 ; get right digit counter + bne L9050 ; brif we want stuff after decimal + leau -1,u ; delete decimal if not needed +L9050 deca ; subtract one place (for decimal) + jsr L90EA ; put zeroes in buffer (trailing) +L9054 jsr L9185 ; insert * padding, floating $, and post-sign + tsta ; was there a post sign? + beq L9060 ; brif not + cmpb #'* ; was first character a *? + beq L9060 ; brif so + stb ,u+ ; store the post sign +L9060 clr ,u ; make srue it's NUL terminated + ldx #STRBUF+3 ; point to start of buffer +L9065 leax 1,x ; move to next character + stx TEMPTR ; save it for later + lda VARPTR+1 ; get address of decimal point + suba TEMPTR+1 ; subtract out actual digits left of decimal + suba VD9 ; subtract out required left digits + beq L90A9 ; brif no padding needed + lda ,x ; get current character + cmpa #0x20 ; space? + beq L9065 ; brif so - advance pointer + cmpa #'* ; *? + beq L9065 ; brif so - advance pointer + clra ; zero on stack is end of data ponter +L907C pshs a ; save character on stack + lda ,x+ ; get next character + cmpa #'- ; minus? + beq L907C ; brif so + cmpa #'+ ; plus? + beq L907C ; brif so + cmpa #'$ ; $? + beq L907C ; brif so + cmpa #'0 ; zero? + bne L909E ; brif not + lda 1,x ; get character after 0 + bsr L90AA ; clear carry if number + bcs L909E ; brif not number +L9096 puls a ; get character off stack + sta ,-x ; put it back in string buffer + bne L9096 ; brif not - restore another + bra L9065 ; keep cleaning up buffer +L909E puls a ; get the character on the stack + tsta ; is it NUL? + bne L909E ; brif not + ldx TEMPTR ; get string buffer start pointer + lda #'% ; put error flag in front + sta ,-x +L90A9 rts +L90AA cmpa #'0 ; zero? + blo L90B2 ; brif not + suba #'9+1 ; set C if > "9" + suba #-('9+1) +L90B2 rts +L90B3 lda VD8 ; get right digit counter + beq L90B8 ; brif not right digits + deca ; account for decimal point +L90B8 adda V47 ; add base 10 exponent offset + bmi L90BD ; if >= 0, no shifts are required + clra ; force shift counter to 0 +L90BD pshs a ; save shift counter +L90BF bpl L90CB ; brif positive count + pshs a ; save shift counter + jsr LBB82 ; divide FPA0 by 10 (shift 1 digit to the right) + puls a ; get shift counter back + inca ; account for the shift + bra L90BF ; see if we're done yet +L90CB lda V47 ; get base 10 exponent offset + suba ,s+ ; account for adjustment + sta V47 ; save new exponent offset + adda #9 ; account for significant places + bmi L90EE ; brif we don't need zeroes to left + lda VD9 ; get left decimal counter + suba #9 ; account for significant figures + suba V47 ; subtract exponent offset + bsr L90EA ; output leading zeroes + jsr L9263 ; initialize decimal and comma counters + bra L90FF ; process remainder of digits +L90E2 pshs a ; save zero counter + lda #'0 ; insert a 0 + sta ,u+ + puls a ; get back counter +L90EA deca ; do we need more zeroes? + bpl L90E2 ; brif so + rts +L90EE lda VD9 ; get left digit counter + bsr L90EA ; put that many zeroes in + jsr L924D ; put decimal in buffer + lda #-9 ; figure out filler zeroes + suba V47 + bsr L90EA ; output required leader zeroes + clr V45 ; clear decimal pointer counter + clr VD7 ; clear comma counter +L90FF jsr L9202 ; decode FPA0 to decimal string + lda VD8 ; get right digit counter + bne L9108 ; brif there are right digits + ldu VARPTR ; point to decimal location of decimal +L9108 adda V47 ; add base 10 exponent + lbra L9050 ; add in leading astrisks, etc. +L910D lda FP0EXP ; get exponent of FPA0 + pshs a ; save it + beq L9116 ; brif 0 + jsr L91CD ; convert to number with 9 figures +L9116 lda VD8 ; get right digit counter + beq L911B ; brif no right digits + deca ; account for decimal point +L911B adda VD9 ; get left digit counter + clr STRBUF+3 ; use buffer byte as temporary storage + ldb VDA ; get status flags + andb #4 ; post-sign? + bne L9129 ; brif so + com STRBUF+3 ; flip byte if no post sign +L9129 adda STRBUF+3 ; subtract 1 if no post sign + suba #9 ; account for significant figures + pshs a ; save shift counter +L9130 bpl L913C ; brif no more shifts needed + pshs a ; save counter + jsr LBB82 ; divide by 10 (shift right one) + puls a ; get back counter + inca ; account for the shift + bra L9130 ; see if we need more +L913C lda ,s ; get original shift count + bmi L9141 ; brif shifting happened + clra ; flag for no shifting +L9141 nega ; calculate position of decimal (negate shift count, add left digit and post sign if needed) + adda VD9 ; add left digit counter + inca ; and post sign + adda STRBUF+3 + sta V45 ; save decimal counter + clr VD7 ; clear comma counter + jsr L9202 ; convert to decimal string + puls a ; get shift counter + jsr L9281 ; put the needed zeroes in + lda VD8 ; get right digit counter + bne L915A ; brif we want some + leau -1,u ; remove te decimal point +L915A ldb ,s+ ; get original exponent + beq L9167 ; brif it was 0 + ldb V47 ; get base 10 exponent + addb #9 ; account for significant figures + subb VD9 ; remove left digit count + subb STRBUF+3 ; add one if post sign +L9167 lda #'+ ; positive sign + tstb ; is base 10 exponent positive? + bpl L916F ; brif so + lda #'- ; negative sign + negb ; flip exponent +L916F sta 1,u ; put exponent sign + lda #'E ; put "E" and advance output pointer + sta ,u++ + lda #'0-1 ; initialize digit accumulator +L9177 inca ; bump digit + subb #12 ; are we at the right digit? + bcc L9177 ; brif not + addb #'0+12 ; add ASCII bias and undo extra subtraction + std ,u++ ; save exponent in buffer + clr ,u ; clear final byte in buffer + jmp L9054 ; insert *, $, etc. +L9185 ldx #STRBUF+4 ; point to start of result + ldb ,x ; get sign + pshs b ; save it + lda #0x20 ; default pad with spaces + ldb VDA ; get flags + bitb #0x20 ; padding with *? + puls b + beq L919E ; brif no padding + lda #'* ; pad with * + cmpb #0x20 ; do we have a blank? (positive) + bne L919E ; brif not + tfr a,b ; use pad character +L919E pshs b ; save first character +L91A0 sta ,x+ ; store padding + ldb ,x ; get next character + beq L91B6 ; brif end of string + cmpb #'E ; exponent? + beq L91B6 ; brif so - treat as 0 + cmpb #'0 ; zero? + beq L91A0 ; brif so - pad it + cmpb #', ; leading comma? + beq L91A0 ; brif so - pad it + cmpb #'. ; decimal? + bne L91BA ; brif so - don't put a 0 before it +L91B6 lda #'0 ; put a zero before + sta ,-x +L91BA lda VDA ; get status byte + bita #0x10 ; floating $? + beq L91C4 ; brif not + ldb #'$ ; stuff a $ in + stb ,-x +L91C4 anda #4 ; pre-sgn? + puls b ; get back first character + bne L91CC ; brif not + stb ,-x ; save leading character (sign) +L91CC rts +L91CD pshs u ; save buffer pointer + clra ; initial exponent offset is 0 +L91D0 sta V47 ; save exponent offset + ldb FP0EXP ; get actual exponent + cmpb #0x80 ; is value >= 1.0? + bhi L91E9 ; brif so + ldx #LBDC0 ; point to FP number 1E9 + jsr LBACA ; multiply by 1000000000 + lda V47 ; account for 9 shifts + suba #9 + bra L91D0 ; brif not there yet +L91E4 jsr LBB82 ; divide by 10 + inc V47 ; account for shift +L91E9 ldx #LBDBB ; point to 999999999 + jsr LBCA0 ; compare it + bgt L91E4 ; brif not in range yet +L91F1 ldx #LBDB6 ; point to 99999999.9 + jsr LBCA0 ; compare + bgt L9200 ; brif in range + jsr LBB6A ; multiply by 10 + dec V47 ; account for shift + bra L91F1 ; see if we're in range yet +L9200 puls u,pc ; restore buffer pointer and return +L9202 pshs u ; save buffer pointer + jsr LB9B4 ; add .5 (round off) + jsr LBCC8 ; convert to integer format + puls u ; restore buffer pointer + ldx #LBEC5 ; point to 32 bit powers of 10 (alternating signs) + ldb #0x80 ; intitial digit counter is 0 with 0x80 bias +L9211 bsr L9249 ; check for comma +L9213 lda FPA0+3 ; add a 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 ; set V if carry and sign differ + rolb + bvc L9213 ; brif we haven't "wrapped" + bcc L9235 ; brif subtracting + subb #10+1 ; take 9's complement if adding + negb +L9235 addb #'0-1 ; add in ASCII bias + leax 4,x ; move to next power + tfr b,a ; save digit + anda #0x7f ; mask off subtract flag + sta ,u+ ; save digit + comb ; toggle add/subtract + andb #0x80 + cmpx #LBEE9 ; done all places? + bne L9211 ; brif not + clr ,u ; but NUL at end +L9249 dec V45 ; at decimal? + bne L9256 ; brif not +L924D stu VARPTR ; save decimal point pointer + lda #'. ; insert decimal + sta ,u+ + clr VD7 ; clear comma counter + rts +L9256 dec VD7 ; do we need a comma? + bne L9262 ; brif not + lda #3 ; reset comma counter + sta VD7 + lda #', ; insert comma + sta ,u+ +L9262 rts +L9263 lda V47 ; get base 10 exponent offset + adda #10 ; account for significant figures + sta V45 ; save decimal counter + inca ; add one for decimal point +L926A suba #3 ; divide by 3, leave remainder in A + bcc L926A + adda #5 ; renormalize to range 1-3 + sta VD7 ; save comma counter + lda VDA ; get status + anda #0x40 ; commas wanted? + bne L927A ; brif not + sta VD7 ; clear comma counter +L927A rts +L927B pshs a ; save zeroes counter + bsr L9249 ; check for decimal + puls a ; get back counter +L9281 deca ; need a zero? + bmi L928E ; brif not + pshs a ; save counter + lda #'0 ; put a zero + sta ,u+ + lda ,s+ ; get back counter and set flags + bne L927B ; brif not done enough +L928E rts +; From here to the end of the Extended Basic ROM is the PMODE graphics system and related +; infrastructure with the exception of the PLAY command which shares some of its machinery +; with the DRAW command. +; +; Fetch screen address calculation routine address for the selected graphics mode +L928F ldu #L929C ; point to normalization routine jump table + lda PMODE ; get graphics mode + asla ; two bytes per address + ldu a,u ; get routine address + rts +; Normalize VERBEG/HORBEG coordinates and return screen address in X and pixel mask in A. +L9298 bsr L928F ; fetch normalization routine pointer + jmp ,u ; transfer control to it +L929C fdb L92A6 ; PMODE 0 + fdb L92C2 ; PMODE 1 + fdb L92A6 ; PMODE 2 + fdb L92C2 ; PMODE 3 + fdb L92A6 ; PMODE 4 +; Two colour mode address calculatoin +L92A6 pshs u,b ; savce registers + ldb HORBYT ; get number of bytes in each graphics row + lda VERBEG+1 ; get vertical coordinate + mul + addd BEGGRP ; now D is the absolute address of the start of the row + tfr d,x ; get address to the return location + ldb HORBEG+1 ; get horizontal coordinate + lsrb ; divide by 8 (8 pixels per byte in 2 colour mode) + lsrb + lsrb + abx ; now X is the address of the actual pixel byte + lda HORBEG+1 ; get horizontal coordinate + anda #7 ; keep only the low 3 bits which contain the pixel number + ldu #L92DD ; point to pixel mask lookup + lda a,u ; get pixel mask + puls b,u,pc ; restore registers and return result +; four colour address calculation +L92C2 pshs u,b ; save registers + ldb HORBYT ; get bytes per graphics row + lda VERBEG+1 ; get vertical coordinate + mul + addd BEGGRP ; now D is the address of the start of the row + tfr d,x ; put it in returnlocatin + ldb HORBEG+1 ; get horizontal coordinate + lsrb ; divide by 4 (four colour modes have four pixels per byte) + lsrb + abx ; now X points to the screen byte + lda HORBEG+1 ; get horizontal coordinate + anda #3 ; keep low two bits for pixel number + ldu #L92E5 ; point to four colour pixel masks + lda a,u ; get pixel mask + puls b,u,pc ; restore registers and return result +L92DD fcb 0x80,0x40,0x20,0x10 ; two colour pixel masks + fcb 0x08,0x04,0x02,0x01 +L92E5 fcb 0xc0,0x30,0x0c,0x03 ; four colour pixel masks +; Move X down one graphics row +L92E9 ldb HORBYT ; get bytes per row + abx ; add to screen address + rts +; Move one pixel right in 2 colour mode +L92ED lsra ; move pixel mask right + bcc L92F3 ; brif same byte + rora ; move pixel mask to left of byte + leax 1,x ; move to next byte +L92F3 rts +; Move one pixel right in 4 colour mode +L92F4 lsra ; shift mask half a pixel right + bcc L92ED ; brif not past end of byte - shift one more + lda #0xc0 ; set mask on left of byte + leax 1,x ; move to next byte + rts +; Evaluate two expressions (coordinates). Put first in HORBEG and second in VERBEG. +L92FC jsr LB734 ; evaluate two expressions - first in BINVAL, second in B + ldy #HORBEG ; point to storage location +L9303 cmpb #192 ; is vertical outside range? + blo L9309 ; brif not + ldb #191 ; max it at bottom of screen +L9309 clra ; zero extend vertical coordinate + std 2,y ; save vertical coordinate + ldd BINVAL ; get horizontal coordinate + cmpd #256 ; in range? + blo L9317 ; brif so + ldd #255 ; max it out to right side of screen +L9317 std ,y ; save horizontal coordinate + rts +; Normalize coordinates for proper PMODE +L931A jsr L92FC ; parse coordinates +L931D ldu #HORBEG ; point to start coordinates +L9320 lda PMODE ; get graphics mode + cmpa #2 ; is it pmode 0 or 1? + bhs L932C ; brif not + ldd 2,u ; get vertical coordinate + lsra ; divide it by two + rorb + std 2,u ; save it back +L932C lda PMODE ; get graphics mode + cmpa #4 ; pmode 4? + bhs L9338 ; brif so + ldd ,u ; cut horizontal coordinate in half + lsra + rorb + std ,u ; save new coordinate +L9338 rts +; PPOINT function +PPOINT jsr L93B2 ; evaluate two expressions (coordinates) + jsr L931D ; normalize coordinates + jsr L9298 ; get screen address + anda ,x ; get colour value of desired screen coordinate + ldb PMODE ; get graphics mode + rorb ; is it a two colour m ode? + bcc L935B ; brif so +L9349 cmpa #4 ; is it on rightmost bits? + blo L9351 ; brif not + rora ; shift right + rora + bra L9349 ; see if we're there yet +L9351 inca ; colour numbers start at 1 + asla ; add in colour set (0 or 8) + adda CSSVAL + lsra ; get colour in range of 0 to 8 +L9356 tfr a,b ; put result to B + jmp LB4F3 ; return B as FP number +L935B tsta ; is pixel on? + beq L9356 ; brif not, return 0 (off) + clra ; set colour number to "1" + bra L9351 ; make it 1 or 5 and return +; PSET command +PSET lda #1 ; PSET flag + bra L9366 ; go turn on the pixel +; PRESET command +PRESET clra ; PRESET flag +L9366 sta SETFLG ; store whether we're setting or resetting + jsr LB26A ; enforce ( + jsr L931A ; evaluate coordinates + jsr L9581 ; evaluate colour + jsr LB267 ; enforce ) + jsr L9298 ; get address of pixel +L9377 ldb ,x ; get screen data + pshs b ; save it + tfr a,b ; duplicate pixel mask + coma ; invert mask + anda ,x ; turn off screen pixel + andb ALLCOL ; adjust pixel mask to be the current colour + pshs b ; merge pixel data into the screen data + ora ,s+ + sta ,x ; put it on screen + suba ,s+ ; nonzero if screen data changed + ora CHGFLG ; propagate change flag + sta CHGFLG + rts +; Evaluate two sets of coordinates separated by a minus sign. First at HORBEG,VERBEG and +; second at HOREND,VEREND. If no first set, use HORDEF,VERDEF. +L938F ldx HORDEF ; set default start coords + stx HORBEG + ldx VERDEF + stx VERBEG + cmpa #0xac ; do we start with a -? + beq L939E ; brif no starting coordinates + jsr L93B2 ; parse coordinates +L939E ldb #0xac ; make sure we have a - + jsr LB26F + jsr LB26A ; require a ( + jsr LB734 ; evaluate two expressions + ldy #HOREND ; point to storage location + jsr L9303 ; process coordinates + bra L93B8 ; finish up with a ) +L93B2 jsr LB26A ; make sure there's a ( + jsr L92FC ; evaluate coordinates +L93B8 jmp LB267 ; force a ) +; LINE command +LINE cmpa #0x89 ; is it LINE INPUT? + lbeq L89C0 ; brif so - go handle it + cmpa #'( ; starting coord? + beq L93CE ; brif so + cmpa #0xac ; leading -? + beq L93CE ; brif so + ldb #'@ ; if it isn't the above, make sure it's @ + jsr LB26F +L93CE jsr L938F ; parse coordinates + ldx HOREND ; set ending coordinates as the defaults + stx HORDEF + ldx VEREND + stx VERDEF + jsr SYNCOMMA ; make sure we have a comma + cmpa #0xbe ; PRESET? + beq L93E9 ; brif so + cmpa #0xbd ; PSET? + lbne LB277 ; brif not + ldb #01 ; PSET flag + skip1lda ; skip byte and set A nonzero +L93E9 clrb ; PRESET flag + pshs b ; save PSET/PRESET flag + jsr GETNCH ; eat the PSET/PRESET + jsr L9420 ; normalize coordinates + puls b ; get back PSET/PRESET flag + stb SETFLG ; flag which we're doing + jsr L959A ; set colour byte + jsr GETCCH ; get next bit + lbeq L94A1 ; brif no box option + jsr SYNCOMMA ; make sure it's comma + ldb #'B ; make sure "B" for "box" + jsr LB26F + bne L9429 ; brif something follows the B + bsr L9444 ; draw horizontal line + bsr L946E ; draw vertical line + ldx HORBEG ; save horizontal coordinate + pshs x ; save it + ldx HOREND ; switch in horizontal end + stx HORBEG + bsr L946E ; draw vertical line + puls x ; get back original start + stx HORBEG ; put it back + ldx VEREND ; do the same dance with the vertical end + stx VERBEG + bra L9444 ; draw horizontal line +L9420 jsr L931D ; normalize the start coordinates + ldu #HOREND ; point to end coords + jmp L9320 ; normalize those coordinates +L9429 ldb #'F ; make sure we have "BF" for "filled box" + jsr LB26F + bra L9434 ; fill the box +L9430 leax -1,x ; move vertical coordinate up one +L9432 stx VERBEG ; save new vertical coordinate +L9434 jsr L9444 ; draw a horizontal line + ldx VERBEG ; are we at the end of the box? + cmpx VEREND + beq L9443 ; brif so + bcc L9430 ; brif we're moving up the screen + leax 1,x ; move down the screen + bra L9432 ; go draw another line +L9443 rts +; Draw a horizontal line from HORBEG to HOREND at VERBEG using color mask in ALLCOL +L9444 ldx HORBEG ; get starting horizontal coordinate + pshs x ; save it + jsr L971D ; get absolute value of HOREND-HORBEG + bcc L9451 ; brif end is > start + ldx HOREND ; copy end coordinate to start it is smaller + stx HORBEG +L9451 tfr d,y ; save difference - it's a pixel count + leay 1,y ; coordinates are inclusive + jsr L9298 ; get screen position of start coord + puls u ; restore original start coordinate + stu HORBEG + bsr L9494 ; point to routine to move pizel pointers to right +L945E sta VD7 ; save pixel mask + jsr L9377 ; turn on pixel + lda VD7 ; get pixel mask back + jsr ,u ; move one pixel right + leay -1,y ; turned on enough pixels yet? + bne L945E ; brif not +L946B rts +L946C puls b,a ; clean up stack +L946E ldd VERBEG ; save original vertical start coordinate + pshs b,a + jsr L9710 ; get vertical difference + bcc L947B ; brif end coordinate > start + ldx VEREND ; swap in end coordinate if not + stx VERBEG +L947B tfr d,y ; save number of pixels to set + leay 1,y ; the coordinates are inclusive + jsr L9298 ; get screen pointer + puls u ; restore start coordinate + stu VERBEG + bsr L949D ; point to routine to move down one row + bra L945E ; draw vertical line +; Point to routine which will move one pixel right +L948A fdb L92ED ; PMODE 0 + fdb L92F4 ; PMODE 1 + fdb L92ED ; PMODE 2 + fdb L92F4 ; PMODE 3 + fdb L92ED ; PMODE 4 +L9494 ldu #L948A ; point to jump table + ldb PMODE ; get graphics mode + aslb ; two bytes per address + ldu b,u ; get jump address + rts +; Point to routine to move down one row +L949D ldu #L92E9 ; point to "move down one row" routien + rts +; Draw a line from HORBEG,VERBEG to HOREND,VEREND +L94A1 ldy #L950D ; point to increase vertical coord + jsr L9710 ; calculate difference + lbeq L9444 ; brif none - draw a horizontal line + bcc L94B2 ; brif vertical end is > vertical start + ldy #L951B ; point to decrease vertical coord +L94B2 pshs d ; save vertical difference + ldu #L9506 ; point to increase horizontal coord + jsr L971D ; get difference + beq L946C ; brif none - draw a vertical line + bcc L94C1 ; brif horizontal end > horizontal start + ldu #L9514 ; point to decrease hoizontal coord +L94C1 cmpd ,s ; compare vert and horiz differences + puls x ; get X difference + bcc L94CC ; brif horiz diff > vert diff + exg u,y ; swap change routine pointers + exg d,x ; swap differences +L94CC pshs u,d ; save larger difference and routine + pshs d ; save larger difference + lsra ; divide by two + rorb + bcs L94DD ; brif odd number + cmpu #L950D+1 ; increase or decrease? + blo L94DD ; brif increase + subd #1 ; back up one +L94DD pshs x,b,a ; save smallest difference and initial middle offset + jsr L928F ; point to proper coordinate to screen conversion routine +L94E2 jsr ,u ; convert coordinates to screen address + jsr L9377 ; turn on a pixel + ldx 6,s ; get distnace counter + beq L9502 ; brif line is completely drawn + leax -1,x ; account for one pixel drawn + stx 6,s ; save new counter + jsr [8,s] ; increment/decrement larger delta + ldd ,s ; get the minor coordinate increment counter + addd 2,s ; add the smallest difference + std ,s ; save new minor coordinate incrementcounter + subd 4,s ; subtractout the largest difference + bcs L94E2 ; brif not greater - draw another pixel + std ,s ; save new minor coordinate increment + jsr ,y ; adjust minor coordinate + bra L94E2 ; go draw another pixel +L9502 puls x ; clean up stack and return + puls a,b,x,y,u,pc +L9506 ldx HORBEG ; bump horizontal coordinate + leax 1,x + stx HORBEG + rts +L950D ldx VERBEG ; bump vertical coordinate + leax 1,x + stx VERBEG + rts +L9514 ldx HORBEG ; decrement horizontal coordinate + leax -1,x + stx HORBEG + rts +L951B ldx VERBEG ; decrement vertical coordinate + leax -1,x + stx VERBEG + rts +; Get normalized maximum coordinate values in VD3 and VD5 +L9522 ldu #VD3 ; point to temp storage + ldx #255 ; set maximum horizontal + stx ,u + ldx #191 ; set maximum vertical + stx 2,u + jmp L9320 ; normalize them +; PCLS command +PCLS beq L9542 ; clear to background colour if no argument + bsr L955A ; evaluate colour +L9536 lda #0x55 ; consider each byte as 4 groups of 2 bit sub-nibbles + mul ; now colour is in all four sub-pixels + ldx BEGGRP ; get start of graphics screen +L953B stb ,x+ ; set byte to proper colour + cmpx ENDGRP ; at end of graphics page? + bne L953B ; brif not + rts +L9542 ldb BAKCOL ; get background colour + bra L9536 ; do the clearing dance +; COLOR command +COLOR cmpa #', ; check for comma + beq L9552 ; brif no foreground colour + bsr L955A ; evaluate first colour + stb FORCOL ; set foreground colour + jsr GETCCH ; is there a background colour? + beq L9559 ; brif not +L9552 jsr SYNCOMMA ; make sure we have a comma + bsr L955A ; evaluate background colour argument + stb BAKCOL ; set background colour +L9559 rts +; Evaluate a colour agument and convert to proper code based on graphics mode +L955A jsr EVALEXPB ; evaluate colour code +L955D cmpb #9 ; is it in range of 0-8? + lbhs LB44A ; brif not - raise error + clra ; CSS value for first colour set + cmpb #5 ; is it first or second colour set? + blo L956C ; brif first colour set + lda #8 ; flag second colour set + subb #4 ; adjust into basic range +L956C pshs a ; save CSS value + lda PMODE ; get graphics mode + rora ; 4 colour or 2? + bcc L957B ; brif 2 colour + tstb ; was it 0? + bne L9578 ; brif not +L9576 ldb #4 ; if so, make it 4 +L9578 decb ; convert to zero based +L9579 puls a,pc ; get back CSS value and return +L957B rorb ; is colour number odd? + bcs L9576 ; brif so - force all bits set colour + clrb ; force colour 0 if not + bra L9579 +; Set all pixel byte and active colour +L9581 jsr L959A ; set colour byte + jsr GETCCH ; is there something to evaluate? + beq L9598 ; brif not + cmpa #') ; )? + beq L9598 ; brif so + jsr SYNCOMMA ; force comma + cmpa #', ; another comma? + beq L9598 ; brif so + jsr L955A ; evaluate expression and return colour + bsr L95A2 ; save colour and pixel byte +L9598 jmp GETCCH ; re-fetch input character and return +L959A ldb FORCOL ; use foreground colour by default + tst SETFLG ; doing PRESET? + bne L95A2 ; brif not + ldb BAKCOL ; default to background colour +L95A2 stb WCOLOR ; save working colour + lda #0x55 ; consider a byte as 4 pixels + mul ; now all pixels are set to the same bit pattern + stb ALLCOL ; set all pixels byte + rts +L95AA bne L95CF ; brif graphics mode +L95AC pshs x,b,a ; save registers + ldx #SAMREG+8 ; point to middle of control register + sta 10,x ; reset display page to 0x400 + sta 8,x + sta 6,x + sta 4,x + sta 2,x + sta 1,x + sta -2,x + sta -4,x ; reset to alpha mode + sta -6,x + sta -8,x + lda PIA1+2 ; set VDG to alpha mode, colour set 0 + anda #7 + sta PIA1+2 + puls a,b,x,pc ;restore registers and return +L95CF pshs x,b,a ; save registers + lda PMODE ; get graphics mode + adda #3 ; offset to 3-7 (we don't use the bottom 3 modes) + ldb #0x10 ; shift to high 4 bits + mul + orb #0x80 ; set to graphics mode + orb CSSVAL ; set the desired colour set + lda PIA1+2 ; get get original PIA values + anda #7 ; mask off VDG control + pshs a ; merge with new VDG control + orb ,s+ + stb PIA1+2 ; set new VDG mode + lda BEGGRP ; get start of graphics page + lsra ; divide by two - pages are on 512 byte boundaries + jsr L960F ; set SAM control register + lda PMODE ; get graphics mode + adda #3 ; shift to VDG values + cmpa #7 ; PMODE 4? + bne L95F7 ; brif not + deca ; treat PMODE 4 the same as PMODE 3 +L95F7 bsr L95FB ; program SAM's VDG bits + puls a,b,x,pc ; restore registers and return +L95FB ldb #3 ; set 3 bits in register + ldx #SAMREG ; point to VDG control bits +L9600 rora ; get bit to set + bcc L9607 ; brif we need to clear the bit + sta 1,x ; set the bit + bra L9609 +L9607 sta ,x ; clear the bit +L9609 leax 2,x ; move to next bit + decb ; done all bits? + bne L9600 ; brif not + rts +L960F ldb #7 ; 7 screen address bits + ldx #SAMREG+6 ; point to screen address bits in SAM + bra L9600 ; go program SAM bits +L9616 lda PIA1+2 ; get VDG bits + anda #0xf7 ; keep everything but CSS bit + ora CSSVAL ; set correct CSS bit + sta PIA1+2 ; set desired CSS + rts +; PMODE command +PMODETOK cmpa #', ; is first argument missing? + beq L9650 ; brif so + jsr EVALEXPB ; evaluate PMODE number + cmpb #5 ; valid (0-4)? + bhs L966D ; brif not + lda #6 ; get start of graphics memory +L962E sta BEGGRP ; set start of graphics page + aslb ; multiply mode by two (table has two bytes per entry) + ldu #L9706+1 ; point to lookup table + adda b,u ; add in number of 256 byte pages used for graphics screen + cmpa TXTTAB ; does it fit? + bhi L966D ; brif not + sta ENDGRP ; save end of graphics + leau -1,u ; point to bytes per horizontal row + lda b,u ; get bytes per row + sta HORBYT ; set it + lsrb ; restore PMODE value + stb PMODE ; set graphics mode + clra ; set background colour to 0 + sta BAKCOL + lda #3 ; set foreground colour to maximum (3) + sta FORCOL + jsr GETCCH ; is there a starting page number? + beq L966C ; brif not +L9650 jsr LB738 ; evaluate an expression following a comma + tstb ; page 0? + beq L966D ; brif so - not valid + decb ; zero-base it + lda #6 ; each graphics page is 6*256 + mul + addb GRPRAM ; add to start of graphics memory + pshs b ; save start of screen memory + addb ENDGRP ; add current and address + subb BEGGRP ; subtract current start (adds size of screen) + cmpb TXTTAB ; does it fit? + bhi L966D ; brif not + stb ENDGRP ; save new end of graphics + puls b ; get back start of graphics + stb BEGGRP ; set start of graphics +L966C rts +L966D jmp LB44A ; raise FC error +; SCREEN command +SCREEN cmpa #', ; is there a mode? + beq L967F ; brif no mode + jsr EVALEXPB ; get mode argument + tstb ; set Z if alpha + jsr L95AA ; set SAM/VDG for graphics mode + jsr GETCCH ; is there a second argument? + beq L966C ; brif not +L967F jsr LB738 ; evaluate ,<expr> + tstb ; colour set 0? + beq L9687 ; brif so + ldb #8 ; flag for colour set 1 +L9687 stb CSSVAL ; set colour set + bra L9616 ; set up VDG +; PCLEAR command +PCLEAR jsr EVALEXPB ; evaulate number of pages requested + tstb ; 0? + beq L966D ; brif zero - not allowed + cmpb #9 ; more than 8? + bhs L966D ; brif so - not allowed + lda #6 ; there are 6 "pages" per graphics page + mul ; now B is the number of pages to reserve + addb GRPRAM ; add to start of graphics memory + tfr b,a ; now A is the MSB of the start of free memory + ldb #1 ; program memory always starts one above + tfr d,y ; save pointer to program memory + cmpd ENDGRP ; are we trying to deallocate the current graphics page? + lblo LB44A ; brif so + subd TXTTAB ; subtract out current start of basic program + addd VARTAB ; add in end of program - now D is new top of program + tfr d,x ; save new end of program + addd #200 ; make some extra space (for stack) + subd FRETOP ; see if new top of program fits + bhs L966D ; brif there isn't enough space + ldu VARTAB ; get end of program + stx VARTAB ; save new end of program + cmpu VARTAB ; is old end higher? + bhs L96D4 ; brif so +L96BD lda ,-u ; copy a byte upward + sta ,-x + cmpu TXTTAB ; at beginning? + bne L96BD ; brif not + sty TXTTAB ; save new start of program + clr -1,y ; there must always be a NUL before the program +L96CB jsr LACEF ; re-assign basic program addresses + jsr LAD26 ; reset variables and stack + jmp LAD9E ; return to interpretation loop +L96D4 ldu TXTTAB ; get start of program + sty TXTTAB ; save new start of program + clr -1,y ; there must be a NUL at the start of the program +L96DB lda ,u+ ; move a byte downward + sta ,y+ + cmpy VARTAB ; at the top of the program? + bne L96DB ; brif not + bra L96CB ; finish up +; Graphics initialization routine - this really should be up at the start of the ROM with the +; rest of the initialization code. +L96E6 ldb #0x1e ; set start of program to 0x1e00 ("PCLEAR 4") + stb TXTTAB + lda #6 ; graphics memory starts immediately after the screen +L96EC sta GRPRAM ; set graphics memory start + sta BEGGRP ; set start of current graphics page + clra ; set PMODE to 0 + sta PMODE + lda #16 ; 16 bytes per graphics row + sta HORBYT + lda #3 ; set foreground colour to 3 + sta FORCOL + lda #0x0c ; set ending graphics page (for PMODE 0) + sta ENDGRP + ldx TXTTAB ; get start of program + clr -1,x ; make sure there's a NUL before it +L9703 jmp LAD19 ; do a "NEW" +; PMODE data table (bytes per row and number of 256 byte pages required for a screen) +L9706 fcb 16,6 ; PMODE 0 + fcb 32,12 ; PMODE 1 + fcb 16,12 ; PMODE 2 + fcb 32,24 ; PMODE 3 + fcb 32,24 ; PMODE 4 +; Calculate absolute value of vertical coordinate difference +L9710 ldd VEREND ; get ending address + subd VERBEG ; get difference +L9714 bcc L9751 ; brif we didn't carry + pshs cc ; save status (C set if start > end) + jsr L9DC3 ; negate the difference to be positive + puls cc,pc ; restore C and return +; Calculate absolute value of horizontal coordinate difference +L971D ldd HOREND ; get end coordinate + subd HORBEG ; calculate difference + bra L9714 ; turn into absolute value +; PCOPY command +PCOPY bsr L973F ; fetch address of the source page + pshs d ; save address + ldb #0xa5 ; make sure we have TO + jsr LB26F + bsr L973F ; fetch address of the second page + puls x ; get back source + tfr d,u ; put destination into a pointer + ldy #0x300 ; 0x300 words to copy +L9736 ldd ,x++ ; copy a word + std ,u++ + leay -1,y ; done? + bne L9736 ; brif not + rts +L973F jsr EVALEXPB ; evaluate page number + tstb ; zero? + beq L9752 ; brif invalid page number +; BUG: this should be deferred until after the address is calculated at which point it should +; be bhs instead of bhi. There should also be a check to make sure the page number is less than +; or equal to 8 above so we don't have to test for overflows below. + cmpb TXTTAB ; is page number higher than start of program (BUG!) + bhi L9752 ; brif so - error + decb ; zero-base the page number + lda #6 ; 6 "pages" per graphics page + mul ; now we have proper number of "pages" for the offset + addb GRPRAM ; add start of graphics memory + exg a,b ; put MSB into A, 0 into B. +L9751 rts +L9752 jmp LB44A ; raise illegal function call +; GET command +GET clrb ; GET flag + bra L975A ; go on to the main body +PUT ldb #1 ; PUT flag +L975A stb VD8 ; save GET/PUT flag + jsr RVEC22 ; do the RAM hook dance (so Disk Basic can do its thing) +L975F cmpa #'@ ; @ before coordinates? + bne L9765 ; brif not + jsr GETNCH ; eat the @ +L9765 jsr L938F ; evaluate start/end coordinates + jsr SYNCOMMA ; make sure we have a comma + jsr L98CC ; get pointer to array + tfr X,D ; save descriptor pointer + ldu ,x ; get offset to next descriptor + leau -2,u ; move back to array name + leau d,u ; point to end of array + stu VD1 ; save end of data + leax 2,x ; point to number of dimensions + ldb ,x ; get dimension count + aslb ; two bytes per dimension size + abx ; now X points to start of data + stx VCF ; save start of array data + lda VALTYP ; is it numeric + bne L9752 ; brif not + clr VD4 ; set default graphic action to PSET + jsr GETCCH ; get input character + beq L97B7 ; brif no action flag + com VD4 ; flag action enabled + jsr SYNCOMMA ; make sure there's a comma + tst VD8 ; PUT? + bne L979A ; brif so + ldb #'G ; check for full graphics option + jsr LB26F + bra L97CA ; handle the rest of the process +L979A ldb #5 ; 5 legal actions for PUT + ldx #L9839 ; point to action table +L979F ldu ,x++ ; get "clear bit" action routine + ldy ,x++ ; get "set bit" action routine + cmpa ,x+ ; does token match? + beq L97AE ; brif so + decb ; checked all? + bne L979F ; brif not + jmp LB277 ; raise error +L97AE sty VD5 ; save set bit action address + stu VD9 ; save clear bit action address + jsr GETNCH ; munch the acton token + bra L97CA ; handle rest of process +L97B7 ldb #0xf8 ; mask for bottom three bits + lda PMODE ; get graphics mode + rora ; odd number mode? + bcc L97C0 ; brif even + ldb #0xfc ; bottom 2 bits mask +L97C0 tfr b,a ; save mask + andb HORBEG+1 ; round down the start address + stb HORBEG+1 + anda HOREND+1 ; round down end address + sta HOREND+1 +L97CA jsr L971D ; get horizontal size + bcc L97D3 ; brif end > start + ldx HOREND ; switch end in for start + stx HORBEG +L97D3 std HOREND ; save size + jsr L9710 ; calculate vertical size + bcc L97DE ; brif end > start + ldx VEREND ; swap in vertical end for the start + stx VERBEG +L97DE std VEREND ; save vertical size + lda PMODE ; get graphics mode + rora ; even? + ldd HOREND ; get difference + bcc L97EB ; brif even (2 colour) + addd HOREND ; add in size (double it) + std HOREND ; save adjusted end size +L97EB jsr L9420 ; normalize differences + ldd HOREND ; get end coord + ldx VEREND ; get end size + leax 1,x ; make vertical size inclusive + stx VEREND ; save it back + tst VD4 ; got "G" or GET action + bne L9852 ; brif given + lsra ; we're going for whole bytes here + rorb + lsra + rorb + lsra + rorb + addd #1 ; make it inclusive + std HOREND ; save new coordinate + jsr L9298 ; convert to screen address +L9808 ldb HOREND+1 ; get horizontal size + pshs x ; save screen position +L980C tst VD8 ; get/put flag + beq L9831 ; brif get + bsr L9823 ; bump array data pointer + lda ,u ; copy data from array to screen + sta ,x+ +L9816 decb ; are we done the row? + bne L980C ; brif not + puls x ; get screen address + jsr L92E9 ; move to next row + dec VEREND+1 ; done? + bne L9808 ; brif not +L9822 rts +L9823 ldu VCF ; get array data location + leau 1,u ; bump it + stu VCF ; save new array data location + cmpu VD1 ; did we hit the end of the array? + bne L9822 ; brif not +L982E jmp LB44A ; raise function call error +L9831 lda ,x+ ; get data from screen + bsr L9823 ; bump array data pointer + sta ,u ; put data in array + bra L9816 ; do the loopy thing +; PUT actions +L9839 fdb L9894,L989B ; PSET + fcb 0xbd + fdb L989B,L9894 ; PRESET + fcb 0xbe + fdb L98B1,L989B ; OR + fcb 0xb1 + fdb L9894,L98B1 ; AND + fcb 0xb0 + fdb L98A1,L98A1 ; NOT + fcb 0xa8 +L9852 addd #1 ; add to horiz difference + std HOREND ; save it + lda VD8 ; PUT? + bne L9864 ; brif so + ldu VD1 ; get end of array +L985D sta ,-u ; zero out a byte + cmpu VCF ; done? + bhi L985D ; brif not +L9864 jsr L9298 ; get screen address + ldb PMODE ; get graphics mode + rorb ; even? + bcc L986E ; brif so + anda #0xaa ; use as pixel mask for 4 colour mode +L986E ldb #1 ; set bit probe + ldy VCF ; point to start of array data +L9873 pshs x,a ; save screen address + ldu HOREND ; get horizontal size +L9877 pshs u,a ; save horizontal size and pixel mask + lsrb ; move bit probe right + bcc L9884 ; brif we didn't fall off a byte + rorb ; shift carry back in on the left + leay 1,y ; move ahead a byte in the array + cmpy VD1 ; end of array data? + beq L982E ; raise error if so +L9884 tst VD8 ; PUT? + beq L98A7 ; brif not + bitb ,y ; test bit in array + beq L9890 ; brif not set + jmp [VD5] ; do action routine for bit set +L9890 jmp [VD9] ; do action routine for bit clear +L9894 coma ; invert mask + anda ,x ; read screen data and reset the desired bit + sta ,x ; save on screen + bra L98B1 +L989B ora ,x ; merge pixel mask with screen data (turn on bit) + sta ,x ; save on screen + bra L98B1 +L98A1 eora ,x ; invert the pixel in the screen data + sta ,x ; save on screen + bra L98B1 +L98A7 bita ,x ; is the bit set? + beq L98B1 ; brif not - do nothing + tfr b,a ; get bit probe + ora ,y ; turn on proper bit in data + sta ,y +L98B1 puls a,u ; get back array address + jsr L92ED ; move screen address to the right + leau -1,u ; account for consumed pixel + cmpu ZERO ; done yet? + bne L9877 ; brif not + ldx 1,s ; get start of row back + lda HORBYT ; get number of bytes per row + leax a,x ; move ahead one line + puls a ; get back screen pixel mask + leas 2,s ; lose the screen pointer + dec VEREND+1 ; done all rows? + bne L9873 ; brif not + rts +L98CC jsr LB357 ; evaluate a variable + ldb ,-x ; get variable name + lda ,-x + tfr d,u ; save it + ldx ARYTAB ; get start of arrays +L98D7 cmpx ARYEND ; end of arrays? + lbeq LB44A ; brif not found + cmpu ,x ; correct variable? + beq L98E8 ; brif so + ldd 2,x ; get array size + leax d,x ; move to next array + bra L98D7 ; check this array +L98E8 leax 2,x ; move pointer to the array header + rts ; obviously this rts is not needed +L98EB rts +; PAINT command +PAINT cmpa #'@ ; do we have @ before coords? + bne L98F2 ; brif not + jsr GETNCH ; eat the @ +L98F2 jsr L93B2 ; evaluate coordinates + jsr L931D ; normalize coordinates + lda #1 ; PSET flag (use working colour) + sta SETFLG + jsr L9581 ; parse colour and set working colour, etc. + ldd WCOLOR ; get working colour and all pixels byte + pshs d ; save them + jsr GETCCH ; is there anything else? + beq L990A ; brif not + jsr L9581 ; evaluate border colour +L990A lda ALLCOL ; get border colour all pixel byte + sta VD8 ; save border colour pixel byte + puls d ; get back working colour details + std WCOLOR + clra ; store a "stop" frame on the stack so PAINT knows when it's finished unwinding + pshs u,x,b,a + jsr L9522 ; set up starting coordinates + jsr L928F ; point to pixel mask routine + stu VD9 ; save pixel mask routine + jsr L99DF ; paint from current horizontal coordinate to zero (left) + beq L9931 ; brif hit border immediately + jsr L99CB ; paint from current horizontal coordinate upward (right) + lda #1 ; set direction to "down" + sta VD7 + jsr L99BA ; save "down" frame + neg VD7 ; set direction to "up" + jsr L99BA ; save "up" frame +L9931 sts TMPSTK ; save stack pointer +L9934 tst CHGFLG ; did the paint change anything? + bne L993B ; brif so + lds TMPSTK ; get back stack pointer +L993B puls a,b,x,u ; get frame from stack + clr CHGFLG ; mark nothing changed + sts TMPSTK ; save stack pointer + leax 1,x ; move start coordinate right + stx HORBEG ; save new coordinate + stu VD1 ; save length of line + sta VD7 ; save up/down flag + beq L98EB ; did we hit the "stop" frame? + bmi L9954 ; brif negative going (up)? + incb ; bump vertical coordinate + cmpb VD6 ; at end? + bls L9958 ; brif not + clrb ; set vertical to 0 (wrap around) +L9954 tstb ; did we wrap? + beq L9934 ; do another block if so + decb ; move up a row +L9958 stb VERBEG+1 ; save vertical coordinate + jsr L99DF ; paint from horizontal to 0 + beq L996E ; brif we hit the border immediately + cmpd #3 ; less than 3 pixels? + blo L9969 ; brif so + leax -2,x ; move two pixels left + bsr L99A1 ; save paint block on the stack +L9969 jsr L99CB ; continue painting to the right +L996C bsr L99BA ; save paint data frame +L996E coma ; complement length of line just painted and add to length of line + comb +L9970 addd VD1 ; save difference between this line and parent line + std VD1 + ble L998C ; brif parent line is shorter + jsr L9506 ; bump horizontal coordinate + jsr L9A12 ; see if we bounced into the border + bne L9983 ; brif not border + ldd #-1 ; move left + bra L9970 ; keep looking +L9983 jsr L9514 ; move horizontally left + bsr L99C6 ; save horizontal coordinate + bsr L99E8 ; paint right + bra L996C ; save paint block and do more +L998C jsr L9506 ; bump horizontal coordinate + leax d,x ; point to right end of parent line + stx HORBEG ; set as curent coordinate + coma ; get amount we extend past parent line + comb + subd #1 + ble L999E ; brif doesn't extend + tfr d,x ; save length of line + bsr L99A1 ; save paint frame +L999E jmp L9934 +L99A1 std VCB ; save number of pixels painted + puls y ; get return address + ldd HORBEG ; get horizontal coordinate + pshs x,b,a ; save horizontal coordinate and pointer + lda VD7 ; get up/down flag + nega ; reverse it +L99AC ldb VERBEG+1 ; get vertical coordainte + pshs b,a ; save vertical coord and up/down flag + pshs y ; put return address back + ldb #2 ; make sure we haven't overflowed memory + jsr LAC33 + ldd VCB ; get line length back + rts +L99BA std VCB ; save length of painted line + puls y ; get return address + ldd HOREND ; get start coord + pshs x,b,a ; save horizontal start and length + lda VD7 ; get up/down flag + bra L99AC ; finish up with the stack +L99C6 ldx HORBEG ; save current horizontal coord and save it + stx HOREND + rts +L99CB std VCD ; save number of pixels painted + ldy HOREND ; get last horizontal start + bsr L99C6 ; save current coordinate + sty HORBEG ; save coordinate + bsr L99E8 ; paint a line + ldx VCD ; get number painted + leax d,x ; add to the number painted going the other way + addd #1 ; now D is length of line + rts +L99DF jsr L99C6 ; put starting coordinate in end + ldy #L9514 ; decrement horizontal coordinate address + bra L99EE ; go paint line +L99E8 ldy #L9506 ; increment horizontal coordinate address + jsr ,y ; bump coordinate +L99EE ldu ZERO ; initialize pixel count + ldx HORBEG ; get starting coordinate +L99F2 bmi L9A0B ; brif out of range for hoizontal coordinate + cmpx VD3 ; at end? + bhi L9A0B ; brif right of max + pshs u,y ; save counter and inc/dec routine pointer + bsr L9A12 ; at border? + beq L9A09 ; brif so + jsr L9377 ; set pixel to paint colour + puls y,u ; restore counter and inc/dec/pointer + leau 1,u ; bump number of painted pixels + jsr ,y ; inc/dec screen address + bra L99F2 ; go do another pixel +L9A09 puls y,u ; get back counter and inc/dec routine +L9A0B tfr u,d ; save count in D + tfr d,x ; and in X + subd ZERO ; set flags on D (smaller/faster than cmpd ZERO) + rts +L9A12 jsr [VD9] ; get the screen address + tfr a,b ; save pixel mask + andb VD8 ; set pixel to border colour + pshs b,a ; save mask and border + anda ,x ; mask current pixel into A + cmpa 1,s ; does it match border? Z=1 if so + puls a,b,pc ; restore mask, border pixel, and return +; PLAY command +; This is here mixed in with the graphics package because it shares some machinery with DRAW. +PLAY ldx ZERO ; default values for note length, etc. + ldb #1 + pshs x,b ; save default values + jsr LB156 ; evaluate argument + clrb ; enable DA and sound output + jsr LA9A2 + jsr LA976 +L9A32 jsr LB654 ; fetch PLAY string details + bra L9A39 ; go evaluate the string +L9A37 puls b,x ; get back play string details +L9A39 stb VD8 ; save length of string + beq L9A37 ; brif end of string + stx VD9 ; save start of string + lbeq LA974 ; brif NULL string - disable sound and return +L9A43 tst VD8 ; have anything left? + beq L9A37 ; brif not + jsr L9B98 ; get command character + cmpa #'; ; command separator? + beq L9A43 ; brif so - ignore it + cmpa #'' ; '? + beq L9A43 ; brif so - ignore it + cmpa #'X ; execuate sub string? + lbeq L9C0A ; brif so - handle it + bsr L9A5C ; handle other commands + bra L9A43 ; look for more stuff +L9A5C cmpa #'O ; octave? + bne L9A6D ; brif not + ldb OCTAVE ; get current octave + incb ; 1-base it + bsr L9AC0 ; get value if present + decb ; zero-base it + cmpb #4 ; valid octave? + bhi L9ACD ; raise error if not + stb OCTAVE ; save new octave + rts +L9A6D cmpa #'V ; volume? + bne L9A8B ; brif not + ldb VOLHI ; get current high volume limit + lsrb ; shift 2 bits right (DA is 6 bits in high bits) + lsrb + subb #31 ; subtract out mid value offset + bsr L9AC0 ; read argument + cmpb #31 ; maximum range is 31 + bhi L9ACD ; brif out of range + aslb ; adjust back in range + aslb + pshs b ; save new volume + ldd #0x7e7e ; midrange value for both high and low + adda ,s ; add new volume to high limit + subb ,s+ ; subtract volume from low limit + std VOLHI ; save new volume limits (sets high and low amplitudes) + rts +L9A8B cmpa #'L ; note length? + bne L9AB2 ; brif not + ldb NOTELN ; get current length + bsr L9AC0 ; read parameter + tstb ; resulting length 0? + beq L9ACD ; brif so - problem + stb NOTELN ; save new length + clr DOTVAL ; reset note timer scale factor +L9A9A bsr L9A9F ; check for dot + bcc L9A9A ; brif there was one + rts +L9A9F tst VD8 ; check length + beq L9AAD ; brif zero + jsr L9B98 ; get command character + cmpa #'. ; dot? + beq L9AAF ; brif so + jsr L9BE2 ; move input back and bump length +L9AAD coma ; set C to indicate nothing found + rts +L9AAF inc DOTVAL ; bump number of dots + rts +L9AB2 cmpa #'T ; tempo? + bne L9AC3 ; brif not + ldb TEMPO ; get current tempo + bsr L9AC0 ; parse tempo argument + tstb ; 0? + beq L9ACD ; brif so - invalid + stb TEMPO ; save new tempo + rts +L9AC0 jmp L9BAC ; evaluate various operators +L9AC3 cmpa #'P ; pause? + bne L9AEB ; brif not + jsr L9CCB ; evaluate parameter + tstb ; is the pause number 0? + bne L9AD0 ; brif not +L9ACD jmp LB44A ; raise FC error +L9AD0 lda DOTVAL ; save current volume and note scale + ldx VOLHI + pshs x,a + lda #0x7e ; drop DA to mid range + sta VOLHI + sta VOLLOW + clr DOTVAL + bsr L9AE7 ; go play a "silence" + puls a,x ; restore volume and note scale + sta DOTVAL + stx VOLHI + rts +L9AE7 clr ,-s ; set not number 0 + bra L9B2B ; go play it +L9AEB cmpa #'N ; N for "note"? + bne L9AF2 ; brif not - it's optional + jsr L9B98 ; skip the "N" +L9AF2 cmpa #'A ; is it a valid note? + blo L9AFA ; brif not + cmpa #'G ; is it above the note range? + bls L9AFF ; brif not - valid note +L9AFA jsr L9BBE ; evaluate a number + bra L9B22 ; process note value +L9AFF suba #'A ; normalize note number to 0 + ldx #L9C5B ; point to note number lookup table + ldb a,x ; get not number + tst VD8 ; any command characters left? + beq L9B22 ; brif not + jsr L9B98 ; get character + cmpa #'# ; sharp? + beq L9B15 ; brif so + cmpa #'+ ; also sharp? + bne L9B18 ; brif not +L9B15 incb ; add one half tone + bra L9B22 +L9B18 cmpa #'- ; flat? + bne L9B1F ; brif not + decb ; subtract one half tone + bra L9B22 +L9B1F jsr L9BE2 ; back up command pointer +L9B22 decb ; adjust note number (zero base it) + cmpb #11 ; is it valid? + bhi L9ACD ; raise error if not + pshs b ; save note value + ldb NOTELN ; get note length +L9B2B lda TEMPO ; get tempo value + mul ; calculate note duration + std VD5 ; save duration + leau 1,s ; point to where the stack goes after we're done + lda OCTAVE ; get current octave + cmpa #1 ; 0 or 1? + bhi L9B64 ; brif not + ldx #L9C62 ; point to delay table + ldb #2*12 ; 24 bytes per octave + mul ; now we have the base address + abx ; now X points to the octave base + puls b ; get back note value + aslb ; two bytes per delay + abx ; now we're pointing to the delay + leay ,x ; save pointer to note value + bsr L9B8C ; calculate note timer value + std PLYTMR ; set timer for note playing (IRQ will count this down) +L9B49 bsr L9B57 ; set to mid range and delay + lda VOLHI ; get high value + bsr L9B5A ; set to high value and delay + bsr L9B57 ; set to mid range and delay + lda VOLLOW ; get low value + bsr L9B5A ; set to low value and delay + bra L9B49 ; do it again (IRQ will break the loop) +L9B57 lda #0x7e ; mid value for DA with RS232 marking + nop ; a delay to fine tune frequencies +L9B5A sta PIA1 ; set DA + ldx ,y ; get delay value +L9B5F leax -1,x ; count down + bne L9B5F ; brif not done yet + rts +L9B64 ldx #L9C92-2*12 ; point to delay table for octaves 2+ + ldb #12 ; 12 bytes per octave + mul ; now we have the offset to the desired octave + abx ; now we point to the start of the octave + puls b ; get back note value + abx ; now we point to the delay value + bsr L9B8C ; calculate timer value + std PLYTMR ; set play timer (IRQ counts this down) +L9B72 bsr L9B80 ; send mid value and delay + lda VOLHI ; get high value + bsr L9B83 ; send high value and delay + bsr L9B80 ; send low value and delay + lda VOLLOW ; get low value + bsr L9B83 ; send low value and delay + bra L9B72 ; do it again (IRQ will break the loop) +L9B80 lda #0x7e ; mid range value with RS232 marking + nop ; fine tuning delay +L9B83 sta PIA1 ; set DA + lda ,x ; get delay value +L9B88 deca ; count down + bne L9B88 ; brif not done + rts +L9B8C ldb #0xff ; base timer value + lda DOTVAL ; get number of dots + beq L9B97 ; use default value if 0 + adda #2 ; add in constant timer factor + mul ; multiply scale by base + lsra ; divide by two - each increment will increase note timer by 128 + rorb +L9B97 rts +L9B98 pshs x ; save register +L9B9A tst VD8 ; do we have anything left? + beq L9BEB ; brif not - raise error + ldx VD9 ; get parsing address + lda ,x+ ; get character + stx VD9 ; save pointer + dec VD8 ; account for character consumed + cmpa #0x20 ; space? + beq L9B9A ; brif so - skip it + puls x,pc ; restore register and return +L9BAC bsr L9B98 ; get character + cmpa #'+ ; add one? + beq L9BEE ; brif so + cmpa #'- ; subtract one? + beq L9BF2 ; brif so + cmpa #'> ; double? + beq L9BFC ; brif so + cmpa #'< ; halve? + beq L9BF7 ; brif so +L9BBE cmpa #'= ; variable equate? + beq L9C01 ; brif so + jsr L90AA ; clear carry if numeric + bcs L9BEB ; brif not numeric + clrb ; initialize value to 0 +L9BC8 suba #'0 ; remove ASCII bias + sta VD7 ; save digit + lda #10 ; make room for digit + mul + tsta ; did we overflow 8 bits? + bne L9BEB ; brif so + addb VD7 ; add in digit + bcs L9BEB ; brif that overflowed + tst VD8 ; more digits? + beq L9BF1 ; brif not + jsr L9B98 ; get character + jsr L90AA ; clear carry if numeric + bcc L9BC8 ; brif another digit +L9BE2 inc VD8 ; unaccount for character just read + ldx VD9 ; move pointer back + leax -1,x + stx VD9 + rts +L9BEB jmp LB44A ; raise FC error +L9BEE incb ; bump param + beq L9BEB ; brif overflow +L9BF1 rts +L9BF2 tstb ; already zero? + beq L9BEB ; brif so - underflow + decb ; decrease parameter + rts +L9BF7 tstb ; already at 0? + beq L9BEB ; brif so - raise error + lsrb ; halve it + rts +L9BFC tstb ; will it overflow? + bmi L9BEB ; brif so + aslb ; double it + rts +L9C01 pshs u,y ; save registers + bsr L9C1B ; interpret command string as a variable + jsr LB70E ; convert it to an 8 bit number + puls y,u,pc ; restore registers and return +L9C0A jsr L9C1B ; evaluate expression in command string + ldb #2 ; room for 4 bytes? + jsr LAC33 + ldb VD8 ; get the command length and pointer + ldx VD9 + pshs x,b ; save them + jmp L9A32 ; go process the sub string +L9C1B ldx VD9 ; get command pointer + pshs x ; save it + jsr L9B98 ; get input character + jsr LB3A2 ; set carry if not alpha + bcs L9BEB ; brif not a variable reference +L9C27 jsr L9B98 ; get command character + cmpa #'; ; semicolon? + bne L9C27 ; keep scanning if not + puls x ; get back start of variable string + ldu CHARAD ; get current interpreter input pointer + pshs u ; save it + stx CHARAD ; point interpreter at command string + jsr LB284 ; evaluate expression as string + puls x ; restore interpeter input pointer + stx CHARAD + rts +; The bit of Extended Basic's IRQ routine that handles PLAY. Note that everything after +; clr PLYTMR+1 could be replaced with a simple lds 8,s followed by rts. +L9C3E clra ; make sure DP is set to 0 + tfr a,dp + ldd PLYTMR ; is PLAY running? + lbeq LA9BB ; brif not - transfer control on the Color Basic's routine + subd VD5 ; subtract out the interval + std PLYTMR ; save new timer value + bhi L9C5A ; brif it isn't <= 0 + clr PLYTMR ; disable the timer + clr PLYTMR+1 + puls a ; get saved CC + lds 7,s ; set stack to saved U value + anda #0x7f ; clear E flag (to return minimal state) + pshs a ; set fake "FIRQ" stack frame +L9C5A rti +L9C5B fcb 10,12,1,3,5,6,8 ; table of half tone numbers for notes A-G +L9C62 fdb 0x01a8,0x0190,0x017a,0x0164 ; delays for octave 1 + fdb 0x0150,0x013d,0x012b,0x011a + fdb 0x010a,0x00fb,0x00ed,0x00df + fdb 0x00d3,0x00c7,0x00bb,0x00b1 ; delays for octave 2 + fdb 0x00a6,0x009d,0x0094,0x008b + fdb 0x0083,0x007c,0x0075,0x006e +L9C92 fcb 0xa6,0x9c,0x93,0x8b ; delays for octave 3 + fcb 0x83,0x7b,0x74,0x6d + fcb 0x67,0x61,0x5b,0x56 + fcb 0x51,0x4c,0x47,0x43 ; delays for octave 4 + fcb 0x3f,0x3b,0x37,0x34 + fcb 0x31,0x2e,0x2b,0x28 + fcb 0x26,0x23,0x21,0x1f ; delays for octave 5 + fcb 0x1d,0x1b,0x19,0x18 + fcb 0x16,0x14,0x13,0x12 +; DRAW command +DRAW ldx ZERO ; create an empty "DRAW" frame + ldb #1 + pshs x,b + stb SETFLG ; set to "PSET" mode + stx VD5 ; clear update and draw flag + jsr L959A ; set active colour byte + jsr LB156 ; evaluate command string +L9CC6 jsr LB654 ; fetch command string details + bra L9CD3 ; interpret the command string +L9CCB jsr L9B98 ; fetch command character + jmp L9BBE ; evaluate a number +L9CD1 puls b,x ; get previously saved command string +L9CD3 stb VD8 ; save length counter + beq L9CD1 ; brif end of string + stx VD9 ; save pointer + lbeq L9DC7 ; brif overall end of command +L9CDD tst VD8 ; are we at the end of the string? + beq L9CD1 ; brif so - return to previous string + jsr L9B98 ; get command character + cmpa #'; ; semicolon? + beq L9CDD ; brif so - ignore it + cmpa #'' ; '? + beq L9CDD ; brif so - ignore that too + cmpa #'N ; update position toggle? + bne L9CF4 ; brif not + com VD5 ; toggle update position flag + bra L9CDD ; get on for another command +L9CF4 cmpa #'B ; blank flag? + bne L9CFC ; brif not + com VD6 ; toggle blank flag + bra L9CDD ; get on for another command +L9CFC cmpa #'X ; substring? + lbeq L9D98 ; brif so - execute command + cmpa #'M ; move draw position? + lbeq L9E32 ; brif so + pshs a ; save command character + ldb #1 ; default value if no number follows + tst VD8 ; is there something there? + beq L9D21 ; brif not + jsr L9B98 ; get character + jsr LB3A2 ; set C if not alpha + pshs cc ; save alpha state + jsr L9BE2 ; move back pointer + puls cc ; get back alpha flag + bcc L9D21 ; brif it's alpha + bsr L9CCB ; evaluate a number +L9D21 puls a ; get command back + cmpa #'C ; color change? + beq L9D4F ; brif so + cmpa #'A ; angle? + beq L9D59 ; brif so + cmpa #'S ; scale? + beq L9D61 ; brif so + cmpa #'U ; up? + beq L9D8F ; brif so + cmpa #'D ; down? + beq L9D8C ; brif so + cmpa #'L ; left? + beq L9D87 ; brif so + cmpa #'R ; right? + beq L9D82 ; brif so + suba #'E ; normalize the half cardinals to 0 + beq L9D72 ; brif E (45°) + deca ; F (135°?) + beq L9D6D ; brif so + deca ; G (225°?) + beq L9D7B ; brif so + deca ; H (315°?) + beq L9D69 ; brif so +L9D4C jmp LB44A ; raise FC error +L9D4F jsr L955D ; adjust colour for PMODE + stb FORCOL ; save new foreground colour + jsr L959A ; set up working colour and all pixels byte +L9D57 bra L9CDD ; go process another command +L9D59 cmpb #4 ; only 3 angles are valid + bhs L9D4C ; brif not valid + stb ANGLE ; save new angle + bra L9D57 ; go process another command +L9D61 cmpb #63 ; only 64 scale values are possible + bhs L9D4C ; brif out of range + stb SCALE ; save new scale factor + bra L9D57 ; go process another command +L9D69 clra ; make horizontal negative + bsr L9DC4 + skip1 +L9D6D clra ; keep horizontal distance positive + tfr d,x ; make horizontal distance and vertical distance the same + bra L9DCB ; go do the draw thing +L9D72 clra ; zero extend horizontal distance + tfr d,x ; set it as vertical + bsr L9DC4 ; negate horizontal distance + exg d,x ; swap directions (vertical is now negative) + bra L9DCB ; go do the draw thing +L9D7B clra ; zero extend horizontal distance + tfr d,x ; copy horizontal to vertical + bsr L9DC4 ; negate horizontal + bra L9DCB ; go do the drawing thing +L9D82 clra ; zero extend horizontal distance +L9DB3 ldx ZERO ; no vertical distance + bra L9DCB ; go do the drawing things +L9D87 clra ; zero extend horizontal + bsr L9DC4 ; negate horizontal + bra L9DB3 ; zero out vertical and do the drawing thing +L9D8C clra ; zero extend distance + bra L9D92 ; make the distance vertical and zero out horizontal +L9D8F clra ; zero extend distance + bsr L9DC4 ; negate distance +L9D92 ldx ZERO ; zero out vertical distance + exg x,d ; swap vertical and horizontal + bra L9DCB ; go do the drawing thing +L9D98 jsr L9C1B ; evaluate substring expression + ldb #2 ; is there enough room for the state? + jsr LAC33 + ldb VD8 ; save current command string state + ldx VD9 + pshs x,b + jmp L9CC6 ; go evaluate the sub string +L9DA9 ldb SCALE ; get scale factor + beq L9DC8 ; brif zero - default to full size + clra ; zero extend + exg d,x ; put distance somewhere useful + sta ,-s ; save MS of distance + bpl L9DB6 ; brif positive distance + bsr L9DC3 ; negate the distance +L9DB6 jsr L9FB5 ; multiply D and X + tfr u,d ; save ms bytes in D + lsra ; divide by 2 + rorb +L9DBD lsra ; ...divide by 4 + rorb + tst ,s+ ; negative distance? + bpl L9DC7 ; brif it was positive +L9DC3 nega ; negate D +L9DC4 negb + sbca #0 +L9DC7 rts +L9DC8 tfr x,d ; copy unchanged sitance to D + rts +L9DCB pshs b,a ; save horizontal distance + bsr L9DA9 ; apply scale factor to vertical + puls x ; get horizontal distance + pshs b,a ; save scaled vertical + bsr L9DA9 ; apply scale to horizontal + puls x ; get back vertical distance + ldy ANGLE ; get draw angle and scale + pshs y ; save them +L9DDC tst ,s ; is there an angle? + beq L9DE8 ; brif no angle + exg x,d ; swap distances + bsr L9DC3 ; negate D + dec ,s ; account for one tick around the rotation + bra L9DDC ; see if we're there yet +L9DE8 puls y ; get angle and scale back + ldu ZERO ; default end position (horizontal) is 0 + addd HORDEF ; add default horizontal to horizontal distance + bmi L9DF2 ; brif we went negative + tfr d,u ; save calculated end coordindate +L9DF2 tfr x,d ; get vertical distance somewhere useful + ldx ZERO ; default vertical end is 0 + addd VERDEF ; add distance to default vertical start + bmi L9DFC ; brif negative - use 0 + tfr d,x ; save calculated end coordinate +L9DFC cmpu #256 ; is horizontal in range? + blo L9E05 ; brif su + ldu #255 ; maximize it +L9E05 cmpx #192 ; is vertical in range? + blo L9E0D ; brif so + ldx #191 ; maximize it +L9E0D ldd HORDEF ; set starting coordinates for the line + std HORBEG + ldd VERDEF + std VERBEG + stx VEREND ; set end coordinates + stu HOREND + tst VD5 ; are we updating position? + bne L9E21 ; brif not + stx VERDEF ; update default coordinates + stu HORDEF +L9E21 jsr L9420 ; normalize coordindates + tst VD6 ; are we drawing something? + bne L9E2B ; brif not + jsr L94A1 ; draw the line +L9E2B clr VD5 ; reset draw and update flags + clr VD6 + jmp L9CDD ; do another command +L9E32 jsr L9B98 ; get a command character + pshs a ; save it + jsr L9E5E ; evaluate horizontal distance + pshs b,a ; save it + jsr L9B98 ; get character + cmpa #', ; comma between coordinates? + lbne L9D4C ; brif not - raise error + jsr L9E5B ; evaluate vertical distance + tfr d,x ; save vertical distance + puls u ; get horizontal distance + puls a ; get back first command character + cmpa #'+ ; was it + at start? + beq L9E56 ; brif +; treat values as positive + cmpa #'- ; was it -? + bne L9DFC ; brif not - treat it as absolute +L9E56 tfr u,d ; put horizontal distance somewhere useful + jmp L9DCB ; move draw position (relative) +L9E5B jsr L9B98 ; get input character +L9E5E cmpa #'+ ; leading +? + beq L9E69 ; brif so + cmpa #'- ; leading -? + beq L9E6A ; brif so - negative + jsr L9BE2 ; move pointer back one +L9E69 clra ; 0 for +, nonzero for - +L9E6A pshs a ; save sign flag + jsr L9CCB ; evaluate number + puls a ; get sign flag + tsta ; negative? + beq L9E78 ; brif not + clra ; zero extend and negate + negb + sbca #0 +L9E78 rts +; Table of sines and cosines for CIRCLE +L9E79 fdb 0x0000,0x0001 ; subarc 0 + fdb 0xfec5,0x1919 ; subarc 1 + fdb 0xfb16,0x31f2 ; subarc 2 + fdb 0xf4fb,0x4a51 ; subarc 3 + fdb 0xec84,0x61f9 ; subarc 4 + fdb 0xe1c7,0x78ae ; subarc 5 + fdb 0xd4dc,0x8e3b ; subarc 6 + fdb 0xc5e5,0xa269 ; subarc 7 + fdb 0xb506,0xb506 ; subarc 8 +; CIRCLE command +; The circle is drawn as a 64 sided polygon (64 LINE commands essentially) +CIRCLE cmpa #'@ ; is there an @ before coordinates? + bne L9EA3 ; brif not + jsr GETNCH ; eat the @ +L9EA3 jsr L9522 ; get max coordinates for screen + jsr L93B2 ; parse coordinates for circle centre + jsr L931D ; normalize the start coordinates + ldx ,u ; get horizontal coordinate + stx VCB ; save it + ldx 2,u ; get vertical coordinate + stx VCD ; saveit + jsr SYNCOMMA ; make sure we have a comma + jsr LB73D ; evaluate radius expression + ldu #VCF ; point to temp storage + stx ,u ; save radius + jsr L9320 ; normalize radius + lda #1 ; default to PSET + sta SETFLG + jsr L9581 ; evaluate the colour expression + ldx #0x100 ; height/width default value + jsr GETCCH ; is there a ratio? + beq L9EDF ; brif not + jsr SYNCOMMA ; make sure we have a comma + jsr LB141 ; evaluate the ratio + lda FP0EXP ; multiply ratio by 256 + adda #8 + sta FP0EXP + jsr LB740 ; evaluate ratio to X (fraction part in LSB) +L9EDF lda PMODE ; get graphics mode + bita #2 ; is it even? + beq L9EE9 ; brif so + tfr x,d ; double the ratio + leax d,x +L9EE9 stx VD1 ; save height/width ratio + ldb #1 ; set the SET flag to PSET + stb SETFLG + stb VD8 ; set first time flag (set to 0 after arc drawn) + jsr L9FE2 ; evaluate circle starting point (octant, subarc) + pshs b,a ; save startpoint + jsr L9FE2 ; evaluate circle end point (octant, subarc) + std VD9 ; save endp oint + puls a,b +L9EFD pshs b,a ; save current circle position + ldx HOREND ; move end coordinates to start coordinates + stx HORBEG + ldx VEREND + stx VERBEG + ldu #L9E79+2 ; point to sine/cosine table + anda #1 ; even octant? + beq L9F11 ; brif so + negb ; convert 0-7 to 8-1 for odd octants + addb #8 +L9F11 aslb ; four bytes per table entry + aslb + leau b,u ; point to correct table entry + pshs u ; save sine/cosine table entry pointer + jsr L9FA7 ; calculate horizontal offset + puls u ; get back table entry pointer + leau -2,u ; move to cosine entry + pshs x ; save horizontal offset + jsr L9FA7 ; calculate vertical offset + puls y ; put horizontal in Y + lda ,s ; get octant number + anda #3 ; is it 0 or 4? + beq L9F31 ; brif so + cmpa #3 ; is it 3 or 7? + beq L9F31 ; brif so + exg x,y ; swap horizontal and vertical +L9F31 stx HOREND ; save horizontal offset + tfr y,x ; put vertical offset in X + ldd VD1 ; get height/width ratio + jsr L9FB5 ; multiply vertical by h/w ratio + tfr y,d ; save the product to D + tsta ; did it overflow? + lbne LB44A ; brif so + stb VEREND ; save vertical coordinate MSB + tfr u,d ; get LSW of product + sta VEREND+1 ; save LSB of integer part (we have 8 bits of fraction in the ratio) + lda ,s ; get octant + cmpa #2 ; is it 0 or 1? + blo L9F5B ; brif so + cmpa #6 ; is it 6 or 7? + bhs L9F5B ; brif so + ldd VCB ; get horizontal centre + subd HOREND ; subtract horizontal displacement + bcc L9F68 ; brif we didn't overflow the screen + clra ; zero out coordinate if we overflowed the screen + clrb + bra L9F68 +L9F5B ldd VCB ; get horizontal coordinate of the centre + addd HOREND ; add displacement + bcs L9F66 ; brif overlod + cmpd VD3 ; larger than max horizontal coord? + blo L9F68 ; brif not +L9F66 ldd VD3 ; maximize the coordinate +L9F68 std HOREND ; save horizontal ending coordainte + lda ,s ; get octant + cmpa #4 ; is it 0-3? + blo L9F7A ; brif so + ldd VCD ; get vertical coordinate of centre + subd VEREND ; subtract displacement + bcc L9F87 ; brif we didn't overflow the screen + clra ; minimize to top of screen + clrb + bra L9F87 +L9F7A ldd VCD ; get vertical centre coordinate + addd VEREND ; add displacement + bcs L9F85 ; brif we overflowed the screen + cmpd VD5 ; did we go past max coordinate? + blo L9F87 ; brif not +L9F85 ldd VD5 ; maximize the coordinate +L9F87 std VEREND ; save end coordinate + tst VD8 ; check first time flag + bne L9F8F ; do not draw if first time through (it was setting start coord) + bsr L9FDF ; draw the line +L9F8F puls a,b ; get arc number and sub arc + lsr VD8 ; get first time flag value (and clear it!) + bcs L9F9A ; do not check for end point after drawing for first coordinate + cmpd VD9 ; at end point? + beq L9FA6 ; brif drawing finished +L9F9A incb ; bump arc counter + cmpb #8 ; done 8 arcs? + bne L9FA3 ; brif not + inca ; bump octant + clrb ; reset subarc number + anda #7 ; make sure octant number stays in 0-7 range +L9FA3 jmp L9EFD ; go do another arc +L9FA6 rts +L9FA7 ldx VCF ; get radius + ldd ,u ; get sine/cosine table entry + beq L9FB4 ; brif 0 - offset = radius + subd #1 ; adjust values to correct range + bsr L9FB5 ; multiply radius by sine/cosine + tfr y,x ; resturn result in X +L9FB4 rts +L9FB5 pshs u,y,x,b,a ; save registers and reserve temp space + clr 4,s ; reset overflow byte (YH) + lda 3,s ; calcuate B*XL + mul + std 6,s ; put in "U" + ldd 1,s ; calculate B*XH + mul + addb 6,s ; accumluate with previous product + adca #0 + std 5,s ; save in YL,UH + ldb ,s ; calculate A*XL + lda 3,s + mul + addd 5,s ; accumulate with previous partical product + std 5,s ; save in YL,UH + bcc L9FD4 ; brif no carry + inc 4,s ; bump YH for carry +L9FD4 lda ,s ; calculate A*XH + ldb 2,s + mul + addd 4,s ; accumulate with previous partial product + std 4,s ; save in Y (we can't have a carry here) + puls a,b,x,y,u,pc ; restore multiplicands and return results +L9FDF jmp L94A1 ; go draw a line +L9FE2 clrb ; default arc number (0) + jsr GETCCH ; is there something there for a value? + beq L9FF8 ; brif not + jsr SYNCOMMA ; evaluate , + expression + jsr LB141 + lda FP0EXP ; multiply by 64 + adda #6 + sta FP0EXP + jsr LB70E ; get integer value of circle fraction + andb #0x3f ; max value of 63 +L9FF8 tfr b,a ; save arc value in A to calculate octant + andb #7 ; calculate subarc + lsra ; calculate octant + lsra + lsra + rts
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/exbas11.s Sat Dec 08 19:57:01 2018 -0700 @@ -0,0 +1,4039 @@ + *pragma nolist + include defs.s +; These are the entry points in the Color Basic ROM which are used the the Extended Basic ROM. +; They are included here in order to keep the Extended Basic ROM separate from the Color Basic +; ROM. +BAWMST EQU 0xA0E8 +CLOAD EQU 0xA498 +CSAVE EQU 0xA44C +DATA EQU 0xAEE0 +EVALEXPB EQU 0xB70B +GIVABF EQU 0xB4F4 +INT EQU 0xBCEE +LA0E2 EQU 0xA0E2 +LA171 EQU 0xA171 +LA176 EQU 0xA176 +LA35F EQU 0xA35F +LA3ED EQU 0xA3ED +LA406 EQU 0xA406 +LA429 EQU 0xA429 +LA42D EQU 0xA42D +LA444 EQU 0xA444 +LA491 EQU 0xA491 +LA505 EQU 0xA505 +LA578 EQU 0xA578 +LA59A EQU 0xA59A +LA5A5 EQU 0xA5A5 +LA5AE EQU 0xA5AE +LA5C7 EQU 0xA5C7 +LA5E4 EQU 0xA5E4 +LA616 EQU 0xA616 +LA619 EQU 0xA619 +LA635 EQU 0xA635 +LA644 EQU 0xA644 +LA648 EQU 0xA648 +LA65F EQU 0xA65F +LA7E9 EQU 0xA7E9 +LA974 EQU 0xA974 +LA976 EQU 0xA976 +LA9A2 EQU 0xA9A2 +LA9BB EQU 0xA9BB +LAC1E EQU 0xAC1E +LAC33 EQU 0xAC33 +LAC46 EQU 0xAC46 +LAC60 EQU 0xAC60 +LAC73 EQU 0xAC73 +LAC7C EQU 0xAC7C +LAC9D EQU 0xAC9D +LACA8 EQU 0xACA8 +LACEF EQU 0xACEF +LACF1 EQU 0xACF1 +LAD01 EQU 0xAD01 +LAD19 EQU 0xAD19 +LAD21 EQU 0xAD21 +LAD26 EQU 0xAD26 +LAD33 EQU 0xAD33 +LAD9E EQU 0xAD9E +LADC6 EQU 0xADC6 +LADD4 EQU 0xADD4 +LADEB EQU 0xADEB +LAE15 EQU 0xAE15 +LAED2 EQU 0xAED2 +LAF67 EQU 0xAF67 +LAFA4 EQU 0xAFA4 +LB035 EQU 0xB035 +LB141 EQU 0xB141 +LB143 EQU 0xB143 +LB146 EQU 0xB146 +LB156 EQU 0xB156 +LB158 EQU 0xB158 +LB244 EQU 0xB244 +LB262 EQU 0xB262 +LB267 EQU 0xB267 +LB26A EQU 0xB26A +LB26F EQU 0xB26F +LB277 EQU 0xB277 +LB284 EQU 0xB284 +LB2CE EQU 0xB2CE +LB357 EQU 0xB357 +LB35C EQU 0xB35C +LB3A2 EQU 0xB3A2 +LB44A EQU 0xB44A +LB4F3 EQU 0xB4F3 +LB50F EQU 0xB50F +LB518 EQU 0xB518 +LB51A EQU 0xB51A +LB56D EQU 0xB56D +LB643 EQU 0xB643 +LB654 EQU 0xB654 +LB657 EQU 0xB657 +LB659 EQU 0xB659 +LB69B EQU 0xB69B +LB6A4 EQU 0xB6A4 +LB6AD EQU 0xB6AD +LB70E EQU 0xB70E +LB734 EQU 0xB734 +LB738 EQU 0xB738 +LB73D EQU 0xB73D +LB740 EQU 0xB740 +LB7C2 EQU 0xB7C2 +LB958 EQU 0xB958 +LB95C EQU 0xB95C +LB99F EQU 0xB99F +LB9AC EQU 0xB9AC +LB9AF EQU 0xB9AF +LB9B4 EQU 0xB9B4 +LB9B9 EQU 0xB9B9 +LB9C2 EQU 0xB9C2 +LBA1C EQU 0xBA1C +LBA3A EQU 0xBA3A +LBA92 EQU 0xBA92 +LBAC5 EQU 0xBAC5 +LBACA EQU 0xBACA +LBB48 EQU 0xBB48 +LBB5C EQU 0xBB5C +LBB6A EQU 0xBB6A +LBB82 EQU 0xBB82 +LBB8F EQU 0xBB8F +LBC14 EQU 0xBC14 +LBC2F EQU 0xBC2F +LBC35 EQU 0xBC35 +LBC4C EQU 0xBC4C +LBC5F EQU 0xBC5F +LBC6D EQU 0xBC6D +LBCA0 EQU 0xBCA0 +LBCC8 EQU 0xBCC8 +LBD99 EQU 0xBD99 +LBDB6 EQU 0xBDB6 +LBDBB EQU 0xBDBB +LBDC0 EQU 0xBDC0 +LBDC5 EQU 0xBDC5 +LBDCC EQU 0xBDCC +LBDD9 EQU 0xBDD9 +LBEC0 EQU 0xBEC0 +LBEC5 EQU 0xBEC5 +LBEE9 EQU 0xBEE9 +LBEF0 EQU 0xBEF0 +LBEFF EQU 0xBEFF +LBFA6 EQU 0xBFA6 +LET EQU 0xAF89 +PUTCHR EQU 0xA282 +SIN EQU 0xBF78 +SNDBLK EQU 0xA7F4 +STRINOUT EQU 0xB99C +SYNCOMMA EQU 0xB26D +WRLDR EQU 0xA7D8 + *pragma list +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; EXTENDED COLOR BASIC ROM +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + org EXBAS + fcc 'EX' ; magic number that Color Basic uses to identify the presence of Extended Basic +L8002 ldx #L80DE ; point to command interpretation table information + ldu #COMVEC+10 ; point to command interpretation table location + ldb #10 ; 10 bytes to move + jsr LA59A ; copy command interpretation table + ldx #LB277 ; initialize Disk Basic's entries to error + stx 3,u + stx 8,u + ldx #XIRQSV ; set up IRQ service routine + stx IRQVEC+1 + ldx ZERO ; reset the TIMER value + stx TIMVAL + jsr XVEC18 ; do a bunch of initialization + ldd #0x2c05 ; initialize DLOAD baud rate constant and timeout + std DLBAUD + ldx #USR0 ; set up pointer to USR routine addresses + stx USRADR + ldu #LB44A ; set up USR routine addresses to "FC error" + ldb #10 ; there are 10 routines +L8031 stu ,x++ ; set a routine to FC error + decb ; done all? + bne L8031 ; brif not + lda #0x7e ; op code of JMP extended (for RAM hook intialization) + sta RVEC20 ; command interpretation loop + ldx #XVEC20 + stx RVEC20+1 + sta RVEC15 ; expression evaluation + ldx #XVEC15 + stx RVEC15+1 + sta RVEC19 ; number parsing + ldx #XVEC19 + stx RVEC19+1 + sta RVEC9 ; PRINT + ldx #XVEC9 + stx RVEC9+1 + sta RVEC17 ; error handler + ldx #XVEC17 + stx RVEC17+1 + sta RVEC4 ; generic input + ldx #XVEC4 + stx RVEC4+1 + sta RVEC3 ; generic output + ldx #XVEC3 + stx RVEC3+1 + sta RVEC8 ; close file + ldx #XVEC8 + stx RVEC8+1 + sta RVEC23 ; tokenize line + ldx #XVEC23 + stx RVEC23+1 + sta RVEC18 ; RUN + ldx #XVEC18 + stx RVEC18+1 + sta EXPJMP ; exponentiation + ldx #L8489 + stx EXPJMP+1 + jsr L96E6 ; initialize graphics stuff + lda PIA0+3 ; enable 60Hz interrupt + ora #1 + sta PIA0+3 + ldx #'D*256+'K ; magic number for a Disk Basic ROM + cmpx DOSBAS ; do we have a Disk Basic ROM? + lbeq DOSBAS+2 ; brif so - launch it + andcc #0xaf ; enable interrupts + ldx #L80E8-1 ; show sign on message + jsr STRINOUT + ldx #XBWMST ; install warm start handler + stx RSTVEC + jmp LA0E2 ; set up warm start flag and launch immediate mode +; Extended Basic warm start code +XBWMST nop ; flag to mark routine as valid + clr PLYTMR ; cancel any PLAY command in progress + clr PLYTMR+1 + lda PIA0+3 ; enable 60Hz interrupt + ora #1 + sta PIA0+3 + jmp BAWMST ; let Color Basic's warm start process run +; This code is to fix the famous PCLEAR bug. It replaces dead code in the 1.0 ROM. This patch corrects +; the input pointer so that it points to the correct place after the program has been relocated by +; PCLEAR instead of continuing with something that, in the best case, is a syntax error. +L80D0 lda CURLIN ; immediate mode? + inca + beq L80DD ; brif so + tfr y,d ; save offset to D + subd TXTTAB ; see how far into the program we are + addd CHARAD ; now adjust the input pointer based on that + std CHARAD ; save corrected input pointer +L80DD rts +L80DE fcb 25 ; 25 Extended Basic commands + fdb L8183 ; reserved word table (commands) + fdb L813C ; interpretation handler (commands) + fcb 14 ; 14 Extended Basic functions + fdb L821E ; reserved word table (functions) + fdb L8168 ; function handler +L80E8 fcc 'EXTENDED COLOR BASIC 1.1' + fcb 0x0d + fcc 'COPYRIGHT (C) 1982 BY TANDY' + fcb 0x0d + fcc 'UNDER LICENSE FROM MICROSOFT' + fcb 0x0d,0x0d,0x00 +; Extended Basic command interpretation loop +L813C cmpa #0xcb ; is it an Extended Basic command? + bhi L8148 ; brif not + ldx #L81F0 ; point to dispatch table + suba #0xb5 ; normalize the token number so 0 is the first entry + jmp LADD4 ; go transfer control to the command +L8148 cmpa #0xff ; is it a function token? + beq L8154 ; brif so - for MID$()=, TIMER= + cmpa #0xcd ; is it a token for a keyword that isn't a command? + bls L8165 ; brif so - error for USING and FN + jmp [COMVEC+23] ; transfer control to Disk Basic if it is present +L8154 jsr GETNCH ; get token after the function flag + cmpa #0x90 ; MID$? + lbeq L86D6 ; brif so (substring replacement) + cmpa #0x9f ; TIMER? + lbeq L8960 ; brif so - TIMER setting + jsr RVEC22 ; do a RAM hook in case something wants to extend this +L8165 jmp LB277 ; we have nothing valid here +; Function handler +L8168 cmpb #2*33 ; is it a valid Extended Basic function? + bls L8170 ; brif so + jmp [COMVEC+28] ; transfer control to Disk Basic if it is present +L8170 subb #2*20 ; normalize Extended Basic functions to 0 + cmpb #2*8 ; Above HEX$? + bhi L817D ; brif so - we don't pre-evaluate an argument + pshs b ; save token value + jsr LB262 ; evaluate the function parameter + puls b ; get back token value +L817D ldx #L8257 ; point to dispatch table + jmp LB2CE ; go transfer control to the function +; Reserved words (commands) +L8183 fcs 'DEL' ; 0xb5 + fcs 'EDIT' ; 0xb6 + fcs 'TRON' ; 0xb7 + fcs 'TROFF' ; 0xb8 + fcs 'DEF' ; 0xb9 + fcs 'LET' ; 0xba + fcs 'LINE' ; 0xbb + fcs 'PCLS' ; 0xbc + fcs 'PSET' ; 0xbd + fcs 'PRESET' ; 0xbe + fcs 'SCREEN' ; 0xbf + fcs 'PCLEAR' ; 0xc0 + fcs 'COLOR' ; 0xc1 + fcs 'CIRCLE' ; 0xc2 + fcs 'PAINT' ; 0xc3 + fcs 'GET' ; 0xc4 + fcs 'PUT' ; 0xc5 + fcs 'DRAW' ; 0xc6 + fcs 'PCOPY' ; 0xc7 + fcs 'PMODE' ; 0xc8 + fcs 'PLAY' ; 0xc9 + fcs 'DLOAD' ; 0xca + fcs 'RENUM' ; 0xcb + fcs 'FN' ; 0xcc + fcs 'USING' ; 0xcd +; Dispatch table (commands) +L81F0 fdb DEL ; 0xb5 DEL + fdb EDIT ; 0xb6 EDIT + fdb TRON ; 0xb7 TRON + fdb TROFF ; 0xb8 TROFF + fdb DEF ; 0xb9 DEF + fdb LET ; 0xba LET (note: implemented by Color Basic!) + fdb LINE ; 0xbb LINE + fdb PCLS ; 0xbc PCLS + fdb PSET ; 0xbd PSET + fdb PRESET ; 0xbe PRESET + fdb SCREEN ; 0xbf SCREEN + fdb PCLEAR ; 0xc0 PCLEAR + fdb COLOR ; 0xc1 COLOR + fdb CIRCLE ; 0xc2 CIRCLE + fdb PAINT ; 0xc3 PAINT + fdb GET ; 0xc4 GET + fdb PUT ; 0xc5 PUT + fdb DRAW ; 0xc6 DRAW + fdb PCOPY ; 0xc7 PCOPY + fdb PMODETOK ; 0xc8 PMODE + fdb PLAY ; 0xc9 PLAY + fdb DLOAD ; 0xca DLOAD + fdb RENUM ; 0xcb RENUM +; Reserved words (functions) +L821E fcs 'ATN' ; 0x94 + fcs 'COS' ; 0x95 + fcs 'TAN' ; 0x96 + fcs 'EXP' ; 0x97 + fcs 'FIX' ; 0x98 + fcs 'LOG' ; 0x99 + fcs 'POS' ; 0x9a + fcs 'SQR' ; 0x9b + fcs 'HEX$' ; 0x9c + fcs 'VARPTR' ; 0x9d + fcs 'INSTR' ; 0x9e + fcs 'TIMER' ; 0x9f + fcs 'PPOINT' ; 0xa0 + fcs 'STRING$' ; 0xa1 +; Dispatch table (functions) +L8257 fdb ATN ; 0x94 ATN + fdb COS ; 0x95 COS + fdb TAN ; 0x96 TAN + fdb EXP ; 0x97 EXP + fdb FIX ; 0x98 FIX + fdb LOG ; 0x99 LOG + fdb POS ; 0x9a POS + fdb SQR ; 0x9b SQR + fdb HEXDOL ; 0x9c HEX$ + fdb VARPTRTOK ; 0x9d VARPTR + fdb INSTR ; 0x9e INSTR + fdb TIMER ; 0x9f TIMER + fdb PPOINT ; 0xa0 PPOINT + fdb STRING ; 0xa1 STRING$ +; Generic output handler +XVEC3 tst DEVNUM ; screen? + lbeq L95AC ; brif so - force text screen active + pshs b ; save register + ldb DEVNUM ; get output device + cmpb #-3 ; check for DLOAD + puls b ; restore register + bne L8285 ; brif not DLOAD + leas 2,s ; bail out of output handler if DLOAD +L8285 rts +; Close file handler. This corrects a bug in Color Basic 1.0 which didn't handle writing the +; end of file block correctly. That bug is fixed in Color Basic 1.1 so this isn't required +; if a recent enough version of Color Basic is installed. +XVEC8 lda DEVNUM ; get device number + inca ; is it tape? + bne L8285 ; brif not - we aren't going to mess with it + lda FILSTA ; get tape file status + cmpa #2 ; output file? + bne L8285 ; brif not + lda CINCTR ; is there anything waiting to be written out? + bne L8285 ; brif so - mainline code will handle it properly + clr DEVNUM ; reset output to screen + leas 2,s ; don't return to mainline code + jmp LA444 ; write EOF block +; RUN handler - sets up some Extended Basic stuff to defaults at program start +XVEC18 ldd #0xba42 ; initialize PLAY volume + std VOLHI + lda #2 ; set PLAY tempo to 2, PLAY octave to 3 + sta TEMPO + sta OCTAVE + asla ; set default note length to 5 + sta NOTELN + clr DOTVAL ; don't do any note length extension + ldd ZERO ; initialize DRAW angle and scale to default 1 + std ANGLE + ldb #128 ; initialize horizontal and vertical default coordinates to the middle of the screen + std HORDEF + ldb #96 + std VERDEF + rts +; Command interpretation loop handler; we need to intercept this to implement TRON/TROFF +XVEC20 leas 2,s ; don't return to the mainline code +L82BB andcc #0xaf ; make sure interrupts are running + jsr LADEB ; do a BREAK/pause check + ldx CHARAD ; save input pointer + stx TINPTR + lda ,x+ ; get current input character + beq L82CF ; brif end of line + cmpa #': ; statement separator? + beq L82F1 ; brif so + jmp LB277 ; raise error we got here with extra junk +L82CF lda ,x++ ; get first byte of next line address + sta ENDFLG ; use it to set "END" flag to "END" + bne L82D8 ; brif not end of program + jmp LAE15 ; go do the "END" +L82D8 ldd ,x+ ; get line number of next line (and leave pointer one before line text) + std CURLIN ; set current line number + stx CHARAD ; save input pointer + lda TRCFLG ; are we tracing? + beq L82F1 ; brif not + lda #'[ ; show opening marker for TRON line number + jsr PUTCHR + lda CURLIN ; restore MSB of line number + jsr LBDCC ; show line number + lda #'] ; show closing marker for TRON line number + jsr PUTCHR +L82F1 jsr GETNCH ; get the start of the statement + tfr cc,b ; save status flags + cmpa #0x98 ; is it CSAVE? + beq L8316 ; brif so - go to Extended Basic patch (adds CSAVEM) + cmpa #0x97 ; is it CLOAD? + beq L8311 ; brif so - go to Extended Basic patch (adds multi-origin binaries) + tfr b,cc ; restore character status + jsr LADC6 ; go process command + bra L82BB ; restart interpretation loop +; Tokenizaton handler. This is actually a hack to intercept CLOAD and CSAVE during immediate mode by causing the +; tokenization routine to return to the interpretation loop above instead of the mainline interpretation loop. This +; is necessary because the first command encountered on a line in immediate mode is executed BEFORE the interpretation +; loop RAM hook is called. This patch doesn't actually affect tokenization itself at all. +XVEC23 ldx 2,s ; get return address of caller to the tokenizer + cmpx #LAC9D ; is it coming from immediate mode prior to executing the line? + bne L8310 ; brif not + ldx #L82F1 ; force return to Extended Basic's main loop patch above + stx 2,s +L8310 rts +; These two patches are set up this way so that control can be transferred back to the original Color Basic +; implementations if the Extended Basic addons are not triggered. +L8311 jsr L8C62 ; transfer control to Extended Basic's CLOAD handler + bra L82BB ; go do another command +L8316 bsr L831A ; go do Extended Basic's CSAVE handler + bra L82BB ; go do another command +; Extended Basic's CSAVE handler which implements CSAVEM (which Color Basic does not have) +L831A jsr GETNCH ; get character after CSAVE + cmpa #'M ; is it CSAVEM? + lbne CSAVE ; brif not - Color Basic can handle this + jsr GETNCH ; eat the "M" + jsr LA578 ; parse file name + bsr L836C ; get start address + stx CASBUF+13 ; save it in file header + bsr L836C ; get end address + cmpx 2,s ; compare to start address + lblo LB44A ; brif end address is before the start address + bsr L836C ; get execution address + stx CASBUF+11 ; put in file header + jsr GETCCH ; are we at the end of the commmand? + bne L8310 ; brif not + lda #2 ; file type to machine language + ldx ZERO ; set to binary and single block + jsr LA65F ; write header + clr FILSTA ; mark any open tape file closed + inc BLKTYP ; set block type to data + jsr WRLDR ; write a data leader + ldx 4,s ; get starting address +L834D stx CBUFAD ; set start of data address + lda #255 ; try a full length block by default + sta BLKLEN + ldd 2,s ; get ending address + subd CBUFAD ; see how much is left + bhs L835E ; brif we have more to write + leas 6,s ; clean up stack + jmp LA491 ; write EOF block +L835E cmpd #255 ; do we have a full block left? + bhs L8367 ; brif so + incb ; set block size to remainder + stb BLKLEN +L8367 jsr SNDBLK ; write a data block + bra L834D ; go see if we have more to write +L836C jsr SYNCOMMA ; make sure we have a comma + jsr LB73D ; evaluate unsigned expression to X + ldu ,s ; get return address + stx ,s ; save result on stack + tfr u,pc ; return to caller +; COS function +COS ldx #L83AB ; point to PI/2 constant + jsr LB9C2 ; add to argument ( cos(x) = sin((pi/2)+x) ) +L837E jmp SIN ; now calculate sin((pi/2)+x) +; TAN function. This is determined by the identity TAN(X) = SIN(X)/COS(X) +TAN jsr LBC2F ; save FPA0 in FPA3 + clr RELFLG ; reset quadrant flag + bsr L837E ; calculate SIN(x) + ldx #V4A ; save result in FPA5 + jsr LBC35 + ldx #V40 ; get back original argument + jsr LBC14 + clr FP0SGN ; force result positive + lda RELFLG ; get quadrant flag + bsr L83A6 ; calculate COS(x) + tst FP0EXP ; did we get 0 for COS(x) + lbeq LBA92 ; brif so - overflow + ldx #V4A ; point to sin(x) +L83A3 jmp LBB8F ; divide the sin(x) value by the cos(x) value +L83A6 pshs a ; save sign flag + jmp LBFA6 ; expand polynomial +L83AB fcb 0x81,0x49,0x0f,0xda,0xa2 ; pi/2 constant +; ATN function (inverse tangent). There are two calculation streams used to improve precision. +; One if the parameter is >= 1.0 and the other if it is < 1.0 +ATN lda FP0SGN ; get sign of argument + pshs a ; save it + bpl L83B8 ; brif positive + bsr L83DC ; flip sign of argument +L83B8 lda FP0EXP ; get exponent + pshs a ; save it + cmpa #0x81 ; exponent for 1.0 + blo L83C5 ; brif less - value is less than 1.0 + ldx #LBAC5 ; point to FP constant 1.0 + bsr L83A3 ; calculate reciprocal +L83C5 ldx #L83E0 ; point to polynomical coefficients + jsr LBEF0 ; expand polynomial + puls a ; get exponent of argument + cmpa #0x81 ; did we do a reciprocal calculation? + blo L83D7 ; brif not + ldx #L83AB ; subtract result from pi/2 if we did + jsr LB9B9 +L83D7 puls a ; get sign of original + tsta ; was it positive? + bpl L83DF ; brif so +L83DC jmp LBEE9 ; flip sign of result +L83DF rts +; Chebyshev modified taylor series coefficients for inverse tangent. Note that these diverge quite significantly +; from the standard taylor series after 1/9. The standard coefficients are 1/1,-1/3, 1/5, -1/7, 1/9, -1/11, and +; so on. These modified coefficients yield reasonable accuracy for the precision available, presumably with +; fewer coefficients. +L83E0 fcb 11 ; 12 coefficients + fcb 0x76,0xb3,0x83,0xbd,0xd3 ; -0.000684793912 + fcb 0x79,0x1e,0xf4,0xa6,0xf5 ; 0.00485094216 + fcb 0x7b,0x83,0xfc,0xb0,0x10 ; -0.0161117018 + fcb 0x7c,0x0c,0x1f,0x67,0xca ; 0.0342096381 + fcb 0x7c,0xde,0x53,0xcb,0xc1 ; -0.0542791328 + fcb 0x7d,0x14,0x64,0x70,0x4c ; 0.0724571965 + fcb 0x7d,0xb7,0xea,0x51,0x7a ; -0.0898023954 + fcb 0x7d,0x63,0x30,0x88,0x7e ; 0.110932413 + fcb 0x7e,0x92,0x44,0x99,0x3a ; -0.142839808 + fcb 0x7e,0x4c,0xcc,0x91,0xc7 ; 0.199999121 + fcb 0x7f,0xaa,0xaa,0xaa,0x13 ; -0.333333316 + fcb 0x81,0x00,0x00,0x00,0x00 ; 1.0 +; Chebyshev modified taylor series coefficients for the ln(x)/ln(2) (base 2 log of x) +L841D fcb 3 ; four coefficients + fcb 0x7f,0x5e,0x56,0xcb,0x79 ; 0.434255942 from (2/7)/ln(2) + fcb 0x80,0x13,0x9b,0x0b,0x64 ; 0.576584541 from (2/5)/ln(2) + fcb 0x80,0x76,0x38,0x93,0x16 ; 0.961800759 from (2/3)/ln(2) + fcb 0x82,0x38,0xaa,0x3b,0x20 ; 2.88539007 from 2/ln(2) +L8432 fcb 0x80,0x35,0x04,0xf3,0x34 ; 1/sqrt(2) +L8437 fcb 0x81,0x35,0x04,0xf3,0x34 ; sqrt(2) +L843C fcb 0x80,0x80,0x00,0x00,0x00 ; -0.5 +L8441 fcb 0x80,0x31,0x72,0x17,0xf8 ; ln(2) +; LOG function (natural log, ln) +; FP representation is of the form A*2^B. Thus, the log routine determines the value of +; ln(A*2^B). +; +; ln(A*2^B) = ln(A) + ln(2^B) = ln(A) + B*ln(2) = (ln(A)/ln(2) + B)*ln(2), OR: +; (log2(A) + B)*ln(2) +; Now if we write A as A*(sqrt(2)/sqrt(2)), we haven't changed anything so: +; (log2(A*sqrt(2)/sqrt(2)) + B)*ln(2) = (log2(A*sqrt(2)) - log2(sqrt(2)) + B) * ln(2) +; which gives: (-1/2 + log2(A*sqrt(2)) + B) * ln(2) +; +; Everything except log2(A*sqrt(2)) is either constant or trivial. +; +; What the actual code below feeds into the modified taylor series is actually: +; 1 - (sqrt(2)/(A + sqrt(2)) which algebra reveals to be (A*sqrt(2)-1)/(A*sqrt(2)+1) +; +; Thus, the code is using (A*sqrt(2)-1)/(A*sqrt(2)+1) instead of A*sqrt(2) as one would +; expect from the identities. However, the modified coefficients in the series above +; could be correcting for that or the introduced error was deemed acceptable. +; NOTE: this routine does NOT return 0 for LOG(1) +LOG jsr LBC6D ; get status of FPA0 + lble LB44A ; brif <= 0 - logarithms don't exist in that case + ldx #L8432 ; point to 1/sqrt(2) + lda FP0EXP ; get exponent of argument + suba #0x80 ; remove bias + pshs a ; save it for later + lda #0x80 ; force exponent to 0 (this turns FPA0 into A in the above description) + sta FP0EXP + jsr LB9C2 ; add 1/sqrt(2) to A + ldx #L8437 ; point to sqrt(2) + jsr LBB8F ; divide that by FPA0 + ldx #LBAC5 ; point to 1.0 + jsr LB9B9 ; subtract result from 1.0: Now FPA0 is 1-(sqrt(2)/(A+1/sqrt(2))) + ldx #L841D ; point to coefficients + jsr LBEF0 ; expand polynomial (calculate base 2 log of modified argument) + ldx #L843C ; point to -0.5 + jsr LB9C2 ; add result + puls b ; get original exponent back + jsr LBD99 ; add B to FPA0 + ldx #L8441 ; point to ln(2) + jmp LBACA ; multiply by ln(2) which gives us the result in base e +; SQR function (square root) - returns the principle root (positive) +SQR jsr LBC5F ; move argument to FPA1 (first argument for exponentiation) + ldx #LBEC0 ; point to 0.5 (exponent for square root) + jsr LBC14 ; set up second argument to exponentiation (the exponent) +; Exponentiation operator +; This is calculated as A^x = e^(x*ln(A)) where A is in FPA1 and x is in FPA0 +L8489 beq EXP ; do "EXP" if exponent is 0 (this will catch 0^0) + tsta ; check that the base is not 0 + bne L8491 ; brif base is not 0 + jmp LBA3A ; 0^(nonzero) is 0 +L8491 ldx #V4A ; save exponent (to FPA5) + jsr LBC35 + clrb ; result sign will default to positive + lda FP1SGN ; check if base is positive + bpl L84AC ; brif so + jsr INT ; convert exponent to integer + ldx #V4A ; point to original expoent + lda FP1SGN ; get sign of FPA1 + jsr LBCA0 ; compare original exponent with truncated one + bne L84AC ; brif not equal + coma ; flip sign + ldb CHARAC ; get LS byte of integer exponent (result sign flag) +L84AC jsr LBC4C ; copy FPA1 (base) to FPA0 (A = sign) + pshs b ; save result sign + jsr LOG ; get natural log of the base + ldx #V4A ; multiply the log by the exponent + jsr LBACA + bsr EXP ; now raise e to the resulting power + puls a ; get result sign + rora ; brif it was negative + lbcs LBEE9 ; brif negative - flip sign + rts +L84C4 fcb 0x81,0x38,0xaa,0x3b,0x29 ; 1.44269504 (correction factor for exponential function) +; Chebyshev modified taylor series coefficients for e^x +L84C9 fcb 7 ; eight coefficients + fcb 0x71,0x34,0x58,0x3e,0x56 ; 1/(7!*(CF^7)) + fcb 0x74,0x16,0x7e,0xb3,0x1b ; 1/(6!*(CF^6)) + fcb 0x77,0x2f,0xee,0xe3,0x85 ; 1/(5!*(CF^5)) + fcb 0x7a,0x1d,0x84,0x1c,0x2a ; 1/(4!*(CF^4)) + fcb 0x7c,0x63,0x59,0x58,0x0a ; 1/(3!*(CF^3)) + fcb 0x7e,0x75,0xfd,0xe7,0xc6 ; 1/(2!*(CF^2)) + fcb 0x80,0x31,0x72,0x18,0x10 ; 1/(1!*(CF^1)) + fcb 0x81,0x00,0x00,0x00,0x00 ; 1 +; EXP function (e^x) +EXP ldx #L84C4 ; point to correction factor + jsr LBACA ; multiply it + jsr LBC2F ; save corrected argument to FPA3 + lda FP0EXP ; get exponent of FPA0 + cmpa #0x88 ; is it too big? + blo L8504 ; brif not +L8501 jmp LBB5C ; to 0 (underflow) or overflow error +L8504 jsr INT ; convert argument to an integer + lda CHARAC ; get ls byte of integer + adda #0x81 ; was argument 127? if so, the OV error; adds bias + beq L8501 + deca ; adjust for the extra +1 above + pshs a ; save integer exponent + ldx #V40 ; get fractional part of argument + jsr LB9B9 + ldx #L84C9 ; point to coefficients + jsr LBEFF ; evaluate polynomial on the fractional part + clr RESSGN ; force result to be positive + puls a ; get back original exponent + jsr LBB48 ; add original exponent to the fractional result + rts +; FIX function (truncate/round toward 0) (NOTE: INT() always rounds down so INT(-0.5) gives -1 but FIX(-0.5) gives 0) +FIX jsr LBC6D ; get status of argument + bmi L852C ; brif negative +L8529 jmp INT ; do regular "int" if positive +L852C com FP0SGN ; flip the sign + bsr L8529 ; do "INT" on this + jmp LBEE9 ; flip the sign back +; EDIT command +EDIT jsr L89AE ; get line number + leas 2,s ; we're not going to return to the main loop +L8538 lda #1 ; "LIST" flag + sta VD8 ; set to list the line + jsr LAD01 ; find line number + lbcs LAED2 ; brif line wasn't found + jsr LB7C2 ; go unpack the line into the buffer + tfr y,d ; calculate the actual length of the line + subd #LINBUF+2 + stb VD7 ; save line length (it will only be 8 bits) +L854D ldd BINVAL ; get the line number + jsr LBDCC ; display it + jsr LB9AC ; put a space after it + ldx #LINBUF+1 ; point to iput uffer + ldb VD8 ; are we listing? + bne L8581 ; brif so +L855C clrb ; reset digit accumulator +L855D jsr L8687 ; get a keypress + jsr L90AA ; set carry if not numeric + bcs L8570 ; brif not a number + suba #'0 ; remove ASCII bias + pshs a ; save digit value + lda #10 ; multiply accumulator by 10 + mul + addb ,s+ ; add in new digit + bra L855D ; go check for another digit +L8570 subb #1 ; this converts 0 to 1, but *only* 0 to 1 + adcb #1 + cmpa #'A ; abort? + bne L857D ; brif not + jsr LB958 ; to a CR + bra L8538 ; restart EDIT process +L857D cmpa #'L ; list? + bne L858C ; brif not +L8581 bsr L85B4 ; list the line + clr VD8 ; reset to "not listing" + jsr LB958 ; do a CR + bra L854D ; start editing +L858A leas 2,s ; lose return address +L858C cmpa #0x0d ; ENTER? + bne L859D ; brif not + bsr L85B4 ; echo out the line +L8592 jsr LB958 ; do a CR + ldx #LINBUF+1 ; reset input pointer to start of buffer + stx CHARAD + jmp LACA8 ; join immediate mode to replace the line in the program +L859D cmpa #'E ; exit? + beq L8592 ; brif so - end edit with no echo + cmpa #'Q ; quit? + bne L85AB ; brif not + jsr LB958 ; do a CR + jmp LAC73 ; go to immediate mode with no fanfare - no changes saved +L85AB bsr L85AF ; go do commands + bra L855C ; go handle another command +L85AF cmpa #0x20 ; space? + bne L85C3 ; brif not + skip2 +L85B4 ldb #LBUFMX-1 ; display up to a whole line +L85B6 lda ,x ; get buffer chracter + beq L85C2 ; brif end of line + jsr PUTCHR ; output character + leax 1,x ; move to next character + decb ; done? + bne L85B6 ; brif not +L85C2 rts +L85C3 cmpa #'D ; delete? + bne L860F ; brif not +L85C7 tst ,x ; end of line? + beq L85C2 ; brif so - can't delete + bsr L85D1 ; remove a character + decb ; done all requested? + bne L85C7 ; brif not + rts +L85D1 dec VD7 ; account for character being removed + leay -1,x ; set pointer and compensate for increment below +L85D5 leay 1,y ; move to next character + lda 1,y ; get next character + sta ,y ; move it forward + bne L85D5 ; brif we didn't hit the end of the buffer + rts +L85DE cmpa #'I ; insert? + beq L85F5 ; brif so + cmpa #'X ; extend? + beq L85F3 ; brif so + cmpa #'H ; "hack"? + bne L8646 ; brif not + clr ,x ; mark current location as end of line + tfr x,d ; calculate new line length + subd #LINBUF+2 + stb VD7 ; save new length +L85F3 bsr L85B4 ; display the line +L85F5 jsr L8687 ; read a character + cmpa #0x0d ; ENTER? + beq L858A ; brif so - terminate entry + cmpa #0x1b ; ESC? + beq L8625 ; brif so - back to command mode + cmpa #0x08 ; backspace? + bne L8626 ; brif no + cmpx #LINBUF+1 ; are we at the start of the buffer? + beq L85F5 ; brif so - it's a no-op + bsr L8650 ; move pointer back one, do a BS + bsr L85D1 ; remove character from the buffer + bra L85F5 ; go handle more input +L860F cmpa #'C ; change? + bne L85DE ; brif not +L8613 tst ,x ; is there something to change? + beq L8625 ; brif not + jsr L8687 ; get a key stroke + bcs L861E ; brif valid key + bra L8613 ; try again if invalid key +L861E sta ,x+ ; put new character in the buffer + bsr L8659 ; echo it + decb ; changed number requested? + bne L8613 ; brif not +L8625 rts +L8626 ldb VD7 ; get length of line + cmpb #LBUFMX-1 ; at maximum line length? + bne L862E ; brif not + bra L85F5 ; process another input character +L862E pshs x ; save input pointer +L8630 tst ,x+ ; are we at the end of the line? + bne L8630 ; brif not +L8634 ldb ,-x ; get character before current pointer, move back + stb 1,x ; move it forward + cmpx ,s ; at the original buffer pointer? + bne L8634 ; brif not + leas 2,s ; remove saved buffer pointer + sta ,x+ ; save input character in newly made hole + bsr L8659 ; echo it + inc VD7 ; bump line length counter + bra L85F5 ; go handle more stuff +L8646 cmpa #0x08 ; backspace? + bne L865C ; brif not +L864A bsr L8650 ; move pointer back, echo BS + decb ; done enough of them? + bne L864A ; brif not + rts +L8650 cmpx #LINBUF+1 ; at start of buffer? + beq L8625 ; brif so + leax -1,x ; move pointer back + lda #0x08 ; character to echo - BS +L8659 jmp PUTCHR ; echo character to screen +L865C cmpa #'K ; "kill"? + beq L8665 ; brif so + suba #'S ; search? + beq L8665 ; brif so + rts +L8665 pshs a ; save kill/search flag + bsr L8687 ; read target + pshs a ; save search character +L866B lda ,x ; get current character in buffer + beq L8685 ; brif end of line - nothing more to search + tst 1,s ; is it KILL? + bne L8679 ; brif so + bsr L8659 ; echo the character + leax 1,x ; move ahead + bra L867C ; check next character +L8679 jsr L85D1 ; remove character from buffer +L867C lda ,x ; get character in buffer + cmpa ,s ; are we at the target? + bne L866B ; brif not + decb ; have we found enough of them? + bne L866B ; brif not +L8685 puls y,pc ; clean up stack and return to main EDIT routine +L8687 jsr LA171 ; get input from the generic input handler (will show the cursor) + cmpa #0x7f ; graphics (or DEL)? + bhs L8687 ; brif so - ignore it + cmpa #0x5f ; SHIFT-UP? + bne L8694 ; brif not + lda #0x1b ; replace with ESC +L8694 cmpa #0x0d ; carriage return? + beq L86A6 ; brif so (C=0) + cmpa #0x1b ; ESC + beq L86A6 ; brif so (C=0) + cmpa #0x08 ; backspace? + beq L86A6 ; brif so (C=0) + cmpa #32 ; control code? + blo L8687 ; brif control code - try again + orcc #1 ; set C for "valid" (printable) character +L86A6 rts +; TRON and TROFF commands +TRON skip1lda ; load flag with nonzero for trace enabled (and skip next) +TROFF clra ; clear flag for trace disabled + sta TRCFLG ; save trace status + rts +; POS function +POS lda DEVNUM ; get original device number + pshs a ; save it for later + jsr LA5AE ; fetch device number + jsr LA406 ; check for open file + jsr LA35F ; set up print parameters + ldb DEVPOS ; get current line position for the device + jmp LA5E4 ; return position in B as unsigned +; VARPTR function +VARPTRTOK jsr LB26A ; make sure we have ( + ldd ARYEND ; get address of end of arrays + pshs d ; save it + jsr LB357 ; parse variable descriptor + jsr LB267 ; make sure there is a ) + puls d ; get original end of arrays + exg x,d ; swap original end of arrays and the discovered variable pointer + cmpx ARYEND ; did array end move (variable created?) + bne L8724 ; brif so (FC error) + jmp GIVABF ; return the pointer (NOTE: as signed) +; MID$() assignment; note that this cannot make the string longer or shorter and if the replacement is shorter +; than the specified size, only the number of characters actually in the replacement will be used. +L86D6 jsr GETNCH ; eat the MID$ token + jsr LB26A ; force ( + jsr LB357 ; evaluate the variable + pshs x ; save variable descriptor + ldd 2,x ; point to start of original string + cmpd FRETOP ; is it in string space? + bls L86EB ; brif not + subd MEMSIZ ; is it still in string space (top end)? + bls L86FD ; brif so +L86EB ldb ,x ; get length of original string + jsr LB56D ; allocate space in string space + pshs x ; save pointer to string space + ldx 2,s ; get to original string descriptor + jsr LB643 ; move the string into string space + puls x,u ; get new string address and string descriptor + stx 2,u ; save new data address for the string + pshs u ; save descriptor address again +L86FD jsr LB738 ; evaluate ",start" + pshs b ; save start offset + tstb ; is start 0? + beq L8724 ; brif so - strings offsets are 1-based + ldb #255 ; default use the entire string + cmpa #') ; end of parameters? + beq L870E ; brif so + jsr LB738 ; evaluate ",length" +L870E pshs b ; save length + jsr LB267 ; make sure we have a ) + ldb #0xb3 ; make sure we have = + jsr LB26F + bsr L8748 ; evaluate replacement string + tfr x,u ; save replacement string address + ldx 2,s ; get original string descriptor + lda ,x ; get length of original string + suba 1,s ; subtract start position + bhs L8727 ; brif within the string - insert replacement +L8724 jmp LB44A ; raise illegal function call +L8727 inca ; A is now number of characters to the right of the position parameter + cmpa ,s ; compare to length desired + bhs L872E ; brif new length fits + sta ,s ; only use as much of the length as will fit +L872E lda 1,s ; get position offset + exg a,b ; swap replacement length and position + ldx 2,x ; point to original string address + decb ; we work with 0-based offsets + abx ; now X points to start of replacement + tsta ; replacing 0? + beq L8746 ; brif so - done + cmpa ,s ; is replacement shorter than the hole? + bls L873F ; brif so + lda ,s ; use copy the maximum number specified +L873F tfr a,b ; save number to move in B + exg u,x ; swap pointers so they are right for the routine + jsr LA59A ; copy string data +L8746 puls a,b,x,pc ; clean up stack and return +L8748 jsr LB156 ; evaluate expression + jmp LB654 ; make sure it's a string and return string details +; STRING$ function +STRING jsr LB26A ; make sure we have ( + jsr EVALEXPB ; evaluate repeat count (error if > 255) + pshs b ; save repeat count + jsr SYNCOMMA ; make sure there's a comma + jsr LB156 ; evaluate the thing to repeat + jsr LB267 ; make sure we have a ) + lda VALTYP ; is it string? + bne L8768 ; brif so + jsr LB70E ; get 8 bit character code + bra L876B ; use that +L8768 jsr LB6A4 ; get first character of string +L876B pshs b ; save repeat character + ldb 1,s ; get repeat count + jsr LB50F ; reserve space for the string + puls a,b ; get character and repeat count + beq L877B ; brif NULL string +L8776 sta ,x+ ; put character into string + decb ; put enough? + bne L8776 ; brif not +L877B jmp LB69B ; return the newly created string +; INSTR function +INSTR jsr LB26A ; evaluate ( + jsr LB156 ; evaluate first argument + ldb #1 ; default start position is 1 (start of string) + pshs b ; save start position + lda VALTYP ; get type of first argument + bne L879C ; brif string - use default starting position + jsr LB70E ; convert first argument into string offset + stb ,s ; save offset + beq L8724 ; brif starting at 0 - not allowed + jsr SYNCOMMA ; make sure there's a comma + jsr LB156 ; evaluate the search string + jsr LB146 ; make sure it *is* a string +L879C ldx FPA0+2 ; get search string descriptor + pshs x ; save it + jsr SYNCOMMA ; make sure we have a comma + jsr L8748 ; evalute the target string + pshs x,b ; save address and length of target string + jsr LB267 ; make sure we have a ) + ldx 3,s ; get search string address + jsr LB659 ; get string details + pshs b ; save search string length + cmpb 6,s ; compare length of search string to the start + blo L87D9 ; brif start position is beyond the search string - return 0 + lda 1,s ; get length of target string + beq L87D6 ; brif targetstring is NULL - match will be immediate + ldb 6,s ; get start position + decb ; zero-base it + abx ; now X points to the start position for the search +L87BE leay ,x ; point to start of search + ldu 2,s ; get target string pointer + ldb 1,s ; get targetlength + lda ,s ; get length of serach + suba 6,s ; see how much is left in searh + inca ; add one for "inclusivity" + cmpa 1,s ; do we have less than the target string? + blo L87D9 ; brif so - we obviously won't match +L87CD lda ,x+ ; compare a byte + cmpa ,u+ + bne L87DF ; brif no match + decb ; compared all of target? + bne L87CD ; brif not +L87D6 ldb 6,s ; get position where we matched + skip1 +L87D9 clrb ; flag no match + leas 7,s ; clean up stack + jmp LB4F3 ; return unsigned B +L87DF inc 6,s ; bump start position + leax 1,y ; move starting pointer + bra L87BE ; see if we match now +; Number parsing handler +XVEC19 cmpa #'& ; do we have & (hex or octal)? + bne L8845 ; brif not + leas 2,s ; we won't return to the original invoker +L87EB clr FPA0+2 ; clear bottom of FPA0 for 16 bit value + clr FPA0+3 + ldx #FPA0+2 ; point to accumulator + jsr GETNCH ; eat the & + cmpa #'O ; octal? + beq L880A ; brif so + cmpa #'H ; hex? + beq L881F ; brif so + jsr GETCCH ; reset flags on input + bra L880C ; go process octal (default) +L8800 cmpa #'8 ; is it a valid octal character? + lbhi LB277 ; brif not (BUG: should be LBHS or above be #'7) + ldb #3 ; base 8 multiplier + bsr L8834 ; add digit to accumulator +L880A jsr GETNCH ; get input character +L880C bcs L8800 ; brif numeric +L880E clr FPA0 ; clear upper bytes of FPA0 + clr FPA0+1 + clr VALTYP ; result is numeric + clr FPSBYT ; clear out any extra precision + clr FP0SGN ; make it positive + ldb #0xa0 ; exponent for integer aligned to right of FPA0 + stb FP0EXP + jmp LBA1C ; go normalize the result and return +L881F jsr GETNCH ; get input character + bcs L882E ; brif digit + jsr LB3A2 ; set carry if not alpha +L8826 bcs L880E ; brif not alpha + cmpa #'G ; is it valid HEX digit? + bhs L880E ; brif not + suba #7 ; normalize A-F to be just above 0-9 +L882E ldb #4 ; four bits per digit + bsr L8834 ; add digit to accumlator + bra L881F ; process another digit +L8834 asl 1,x ; shift accumulator one bit left + rol ,x + lbcs LBA92 ; brif too big - overflow + decb ; done enough bit shifts? + bne L8834 ; brif not +L883F suba #'0 ; remove ASCII bias + adda 1,x ; merge digit into accumlator (this cannot cause carry) + sta 1,x +L8845 rts +; Expression evaluation handler +XVEC15 puls u ; get back return address + clr VALTYP ; set result to numeric + ldx CHARAD ; save input pointer + jsr GETNCH ; get the input character + cmpa #'& ; HEX or OCTAL? + beq L87EB ; brif so + cmpa #0xcc ; FN? + beq L88B4 ; brif so - do "FNx()" + cmpa #0xff ; function token? + bne L8862 ; brif not + jsr GETNCH ; get function token value + cmpa #0x83 ; USR? + lbeq L892C ; brif so - short circuit Color Basic's USR handler +L8862 stx CHARAD ; restore input pointer + jmp ,u ; return to mainline code +L8866 ldx CURLIN ; are we in immediate mode? + leax 1,x + bne L8845 ; brif not - we're good + ldb #2*11 ; code for illegal direct statement +L886E jmp LAC46 ; raise error +; DEF command (DEF FN, DEF USR) +DEF ldx [CHARAD] ; get two input characters + cmpx #0xff83 ; USR? + lbeq L890F ; brif so - do DEF USR + bsr L88A1 ; get descriptor address for FN variable + bsr L8866 ; disallow DEF FN in immediate mode + jsr LB26A ; make sure we have ( + ldb #0x80 ; disallow arrays as arguments + stb ARYDIS + jsr LB357 ; evaluate variable + bsr L88B1 ; make sure it's numeric + jsr LB267 ; make sure we have ) + ldb #0xb3 ; make sure we have = + jsr LB26F + ldx V4B ; get variable descriptor address + ldd CHARAD ; get input pointer + std ,x ; save address of the actual function code in variable descriptor + ldd VARPTR ; get descriptor address of argument + std 2,x ; save argument descriptor address + jmp DATA ; move to the end of this statement +L88A1 ldb #0xcc ; make sure we have FN + jsr LB26F + ldb #0x80 ; disable array lookup + stb ARYDIS + ora #0x80 ; set bit 7 of first character (to indicate FN variable) + jsr LB35C ; find the variable + stx V4B ; save descriptor pointer +L88B1 jmp LB143 ; make sure we have a numeric variable +; Evaluate an FN call +L88B4 bsr L88A1 ; parse the FNx bit and get the descriptor + pshs x ; save descriptor + jsr LB262 ; evaluate parameter + bsr L88B1 ; make sure it's a number + puls u ; get FN descriptor + ldb #2*25 ; code for undefined function + ldx 2,u ; point to argument variable descriptor + beq L886E ; brif nothing doing there (if it was just created, this will be NULL) + ldy CHARAD ; save current input pointer + ldu ,u ; point to start of FN definition + stu CHARAD ; put input pointer there + lda 4,x ; save original value of argument and save it with current input, and variable pointers + pshs a + ldd ,x + ldu 2,x + pshs u,y,x,d + jsr LBC35 ; set argument variable to the argument +L88D9 jsr LB141 ; go evaluate the FN expression + puls d,x,y,u ; get back variable pointers, input pointer, and original variable value + std ,x + stu 2,x + puls a + sta 4,x + jsr GETCCH ; test end of FN formula + lbne LB277 ; brif not end of statement - problem with the function + sty CHARAD ; restore input pointer +L88EF rts +; Error handler +XVEC17 cmpb #2*25 ; is it a valid Extended Basic error code? + blo L88EF ; brif not - return to mainline + jsr LA7E9 ; turn off tape + jsr LA974 ; turn off sound + jsr LAD33 ; clean up stack and other bits + clr DEVNUM ; reset output to screen + jsr LB95C ; do a newline if needed + jsr LB9AF ; do a ? + ldx #L890B-25*2 ; point to error message table + jmp LAC60 ; go display error message +; Extended Basic error codes. Yes, NE is defined here even though it is only actually documented in the +; Disk Basic documentation. It is here for the use of DLOAD. +L890B fcc 'UF' ; 25 undefined function call + fcc 'NE' ; 26 File not found +; DEF USR +L890F jsr GETNCH ; eat the USR token + bsr L891C ; get pointer to USR call + pshs x ; save FN exec address location + bsr L8944 ; calculate execution address + puls u ; get FN address pointer + stx ,u ; save new address + rts +L891C clrb ; default routine number is 0 + jsr GETNCH ; fetch the call number + bcc L8927 ; brif not a number + suba #'0 ; remove ASCII bias + tfr a,b ; save it in the right place + jsr GETNCH ; eat the call number +L8927 ldx USRADR ; get start address of USR jump table + aslb ; two bytes per address + abx ; now X points to the right entry + rts +; Evaluate a USR call +L892C bsr L891C ; find the correct routine address location + ldx ,x ; get routine address + pshs x ; save it + jsr LB262 ; evaluate argument + ldx #FP0EXP ; point to FPA0 (argument value) + lda VALTYP ; is it string? + beq L8943 ; brif not + jsr LB657 ; fetch string details (removes it from the string stack) + ldx FPA0+2 ; get string descriptor pointer + lda VALTYP ; set flags for the value type +L8943 rts ; call the routine and return to mainline code +L8944 ldb #0xb3 ; check for "=" + jsr LB26F + jmp LB73D ; evaluate integer expression to X and return +; Extended Basic IRQ handler +XIRQSV lda PIA0+3 ; is it VSYNC interrupt? + bmi L8952 ; brif so + rti ; really should clear the HSYNC interrupt here +L8952 lda PIA0+2 ; clear VSYNC interrupt + ldx TIMVAL ; increment the TIMER value + leax 1,x + stx TIMVAL + jmp L9C3E ; check for other stuff +; TIMER= +L8960 jsr GETNCH ; eat the TIMER token + bsr L8944 ; evaluate =nnnn to X + stx TIMVAL ; set the timer + rts +; TIMER function +TIMER ldx TIMVAL ; get timer value + stx FPA0+2 ; set it in FPA0 + jmp L880E ; return as positive 16 bit value +; DEL command +DEL lbeq LB44A ; raise error if no argument (probably to avoid accidentally deleting line 0) + jsr LAF67 ; parse line number + jsr LAD01 ; find line + stx VD3 ; save address of line + jsr GETCCH ; is there something more? + beq L8990 ; brif not + cmpa #0xac ; dash? + bne L89BF ; brif not - error out + jsr GETNCH ; each the - + beq L898C ; brif no ending line - use default line number + bsr L89AE ; parse second line number and save in BINVAL + bra L8990 ; do the deletion +L898C lda #0xff ; set to maximum line number + sta BINVAL +L8990 ldu VD3 ; point end to start + skip2 +L8993 ldu ,u ; point to start of next line + ldd ,u ; check for end of program + beq L899F ; brif end of program + ldd 2,u ; get line number + subd BINVAL ; is it in range? + bls L8993 ; brif so +L899F ldx VD3 ; get starting line address + bsr L89B8 ; close up gap + jsr LAD21 ; reset input pointer and erase variables + ldx VD3 ; get start of program after the deletion + jsr LACF1 ; recompute netl ine pointers + jmp LAC73 ; return to immediate mode +L89AE jsr LAF67 ; parse a line number + jmp LA5C7 ; make sure there's nothing more +L89B4 lda ,u+ ; copy a byte + sta ,x+ +L89B8 cmpu VARTAB ; end of program? + bne L89B4 ; brif not + stx VARTAB ; save new start of variables/end of program +L89BF rts +; LINE INPUT +L89C0 jsr L8866 ; raise error if in immediate mode + jsr GETNCH ; eat the "INPUT" token + cmpa #'# ; device number? + bne L89D2 ; brif not + jsr LA5A5 ; parse device number + jsr LA3ED ; make sure it's valid for input + jsr SYNCOMMA ; make sure there's a comma after the device number +L89D2 cmpa #'" ; is there a prompt? + bne L89E1 ; brif not + jsr LB244 ; parse the string + ldb #'; ; make sure there's a semicolon after the prompt + jsr LB26F + jsr LB99F ; go actually display the prompt +L89E1 leas -2,s ; make a hole on the stack (so number of return adddresses is right) + jsr LB035 ; read an input line from current device + leas 2,s ; clean up stack + clr DEVNUM ; reset to screen/keyboard + jsr LB357 ; parse a variable + stx VARDES ; save pointer to it + jsr LB146 ; make sure it's a string + ldx #LINBUF ; point to input buffer + clra ; make sure we terminate on NUL only + jsr LB51A ; parse string and store it in string space + jmp LAFA4 ; go assign the string to its final resting place +; RENUM command +L89FC jsr LAF67 ; read a line number + ldx BINVAL ; get value + rts +L8A02 ldx VD1 ; get current old number being renumbered +L8A04 stx BINVAL ; save number being searched for + jmp LAD01 ; go find line number +RENUM jsr LAD26 ; erase variables + ldd #10 ; default line number interval and start + std VD5 ; set starting line number + std VCF ; set number interval + clrb ; now D is 0 + std VD1 ; save default start for renumbering + jsr GETCCH ; are there any arguments + bcc L8A20 ; brif not numeric + bsr L89FC ; fetch line number + stx VD5 ; save line beginning number + jsr GETCCH ; get input character +L8A20 beq L8A3D ; brif end of line + jsr SYNCOMMA ; make sure we have a comma + bcc L8A2D ; brif next isn't numeric + bsr L89FC ; fetch starting line number + stx VD1 ; save the number where we start working + jsr GETCCH ; fetch input character +L8A2D beq L8A3D ; brif end of line + jsr SYNCOMMA ; make sure we have a comma + bcc L8A3A ; brif we don't have a number + bsr L89FC ; parse the number + stx VCF ; save interval + beq L8A83 ; brif we ave a zero interval +L8A3A jsr LA5C7 ; raise error if more stuff +L8A3D bsr L8A02 ; get address of old number to process + stx VD3 ; save address + ldx VD5 ; get the next renumbered line to use + bsr L8A04 ; find that line + cmpx VD3 ; is it before the previous one? + blo L8A83 ; brif so - raise error + bsr L8A67 ; make sure renumbered line numbers will be in range + jsr L8ADD ; convert line numbers to "expanded" binary + jsr LACEF ; recalculate next line pointers + bsr L8A02 ; get address of first line to renumber + stx VD3 ; save it + bsr L8A91 ; make sure line numbers exist + bsr L8A68 ; renumber the actual lines + bsr L8A91 ; update line numbers in program text + jsr L8B7B ; convert packed binary line numbers to text + jsr LAD26 ; erase variables, reset stack, etc. + jsr LACEF ; recalculate next line pointers + jmp LAC73 ; bounce back to immediate mode +L8A67 skip1lda ; set line number flag to nonzero (skip next instruction) +L8A68 clra ; set line number flag to zero (insert new numbers) + sta VD8 ; save line number flag + ldx VD3 ; get address of line being renumbered + ldd VD5 ; get the current renumbering number + bsr L8A86 ; return if end of program +L8A71 tst VD8 ; test line number flag + bne L8A77 ; brif not adding new numbers + std 2,x ; set new number +L8A77 ldx ,x ; point to next line + bsr L8A86 ; return if end of program + addd VCF ; add interval to current number + bcs L8A83 ; brif we overflowed - bad line number + cmpa #MAXLIN ; maximum legal number? + blo L8A71 ; brif so - do another +L8A83 jmp LB44A ; raise FC error +L8A86 pshs d ; save D (we're going to clobber it) + ldd ,x ; get next line pointer + puls d ; unclobber D + bne L8A90 ; brif not end of program + leas 2,s ; return to caller's caller +L8A90 rts +L8A91 ldx TXTTAB ; get start of program + leax -1,x ; move pointer back one (compensate for leax 1,x below) +L8A95 leax 1,x ; move to next line + bsr L8A86 ; return if end of program +L8A99 leax 3,x ; move past next line address and line number, go one before line +L8A9B leax 1,x ; move to next character + lda ,x ; check input character + beq L8A95 ; brif end of line + stx TEMPTR ; save current pointer + deca ; is it start of packed numeric line number? + beq L8AB2 ; brif so + deca ; does line exist? + beq L8AD3 ; brif line number exists + deca ; not part of something to process? + bne L8A9B ; brif so +L8AAC lda #3 ; set 1st byte to 3 to indicate line number not existing + sta ,x+ + bra L8A99 ; go process another +L8AB2 ldd 1,x ; get MSB of line number + dec 2,x ; is MS byte zero? + beq L8AB9 ; brif not + clra ; set MS byte to 0 +L8AB9 ldb 3,x ; get LSB of line number + dec 4,x ; is it zero? + beq L8AC0 ; brif not + clrb ; clear byte +L8AC0 std 1,x ; save binary number + std BINVAL ; save trial number + jsr LAD01 ; find the line number +L8AC7 ldx TEMPTR ; get start of packed line + bcs L8AAC ; brif line number not found + ldd V47 ; get address of line number + inc ,x+ ; bump first byte to 2 (exists if checking) or 1 if inserting + std ,x ; save address of correct number + bra L8A99 ; go process more +L8AD3 clr ,x ; clear carry and first byte + ldx 1,x ; point to address of correct line + ldx 2,x ; get correct line number + stx V47 ; save it + bra L8AC7 ; insert into line +L8ADD ldx TXTTAB ; get beginning of program + bra L8AE5 +L8AE1 ldx CHARAD ; get input pointer + leax 1,x ; move it forward +L8AE5 bsr L8A86 ; return if end of program + leax 2,x ; move past line address +L8AE9 leax 1,x ; move forward +L8AEB stx CHARAD ; save input pointer +L8AED jsr GETNCH ; get an input character +L8AEF tsta ; is it actual 0? + beq L8AE1 ; brif end of line + bpl L8AED ; brif not a token + ldx CHARAD ; get input pointer + cmpa #0xff ; function? + beq L8AE9 ; brif so - ignore it (and following byte) + jsr RVEC22 ; do the RAM hook thing + cmpa #0xa7 ; THEN? + beq L8B13 ; brif so + cmpa #0x84 ; ELSE? + beq L8B13 ; brif so + cmpa #0x81 ; GO(TO|SUB)? + bne L8AED ; brif not - we don't have a line number + jsr GETNCH ; get TO/SUB + cmpa #0xa5 ; GOTO? + beq L8B13 ; brif so + cmpa #0xa6 ; GOSUB? + bne L8AEB ; brif not +L8B13 jsr GETNCH ; fetch character after token + bcs L8B1B ; brif numeric (line number) +L8B17 jsr GETCCH ; set flags on input character + bra L8AEF ; keep checking for line numbers +L8B1B ldx CHARAD ; get input pointer + pshs x ; save it + jsr LAF67 ; parse line number + ldx CHARAD ; get input pointer after line +L8B24 lda ,-x ; get character before pointer + jsr L90AA ; set C if numeric + bcs L8B24 ; brif not numeric + leax 1,x ; move pointer up + tfr x,d ; calculate size of line number + subb 1,s + subb #5 ; make sure at least 5 bytes + beq L8B55 ; brif exactly 5 bytes - no change + blo L8B41 ; brif less than 5 bytes + leau ,x ; move remainder of program backward + negb ; negate extra number of bytes (to subtract from X) + leax b,x ; now X is the correct position to move program to + jsr L89B8 ; shift program backward + bra L8B55 +L8B41 stx V47 ; save end of line number space (end of copy) + ldx VARTAB ; get end of program + stx V43 ; set source pointer + negb ; get positive difference + leax b,x ; now X is the top of the destination block + stx V41 ; set copy destination + stx VARTAB ; save new end of program + jsr LAC1E ; make sure enough room and make a hole in the program + ldx V45 ; get end address of destination block + stx CHARAD ; set input there +L8B55 puls x ; get starting address of the line number + lda #1 ; set "new number" flag + sta ,x + sta 2,x + sta 4,x + ldb BINVAL ; get MS byte of line number + bne L8B67 ; brif it is not zero + ldb #1 ; set to 1 if MSB is 0 + inc 2,x ; flag MSB as 0 +L8B67 stb 1,x ; set MSB of line number + ldb BINVAL+1 ; get LSB of number + bne L8B71 ; brif nonzero + ldb #1 ; set to 1 if LSB is 0 + inc 4,x ; flag LSB as 0 +L8B71 stb 3,x ; save LSB of line number + jsr GETCCH ; get input character + cmpa #', ; multiple line numbers? (ON GOTO, ON GOSUB) + beq L8B13 ; brif so - process another + bra L8B17 ; go look for more line numbers +L8B7B ldx TXTTAB ; point to start of program + leax -1,x ; move back (compensate for inc below) +L8B7F leax 1,x ; move forward + ldd 2,x ; get this line number + std CURLIN ; save it (for error message) + jsr L8A86 ; return if end of program + leax 3,x ; skip address and line number, stay one before line text +L8B8A leax 1,x ; move to next character +L8B8C lda ,x ; get input character + beq L8B7F ; brif end of line + deca ; valid line new line number? + beq L8BAE ; brif so + suba #2 ; undefined line? + bne L8B8A ; brif not + pshs x ; save line number pointer + ldx #L8BD9-1 ; show UL message + jsr STRINOUT + ldx ,s ; get input pointer + ldd 1,x ; get undefined line number + jsr LBDCC ; display line number + jsr LBDC5 ; print out "IN XXXX" + jsr LB958 ; do a newline + puls x ; get input pointer back +L8BAE pshs x ; save input pointer + ldd 1,x ; get binary value of line number + std FPA0+2 ; save it in FPA0 + jsr L880E ; adjust FPA0 as integer + jsr LBDD9 ; convert to text string + puls u ; get previous input pointer address + ldb #5 ; each expanded line uses 5 bytes +L8BBE leax 1,x ; move pointer forward (in string number) past sign + lda ,x ; do we have a digit? + beq L8BC9 ; brif not - end of number + decb ; mark a byte consumed + sta ,u+ ; put digit in program + bra L8BBE ; copy another digit +L8BC9 leax ,u ; point to address at end of text number + tstb ; did number fill whole space? + beq L8B8C ; brif so - move on + leay ,u ; save end of number pointer + leau b,u ; point to the end of the original expanded number + jsr L89B8 ; close up gap in program + leax ,y ; get end of line number pointer back + bra L8B8C ; go process more +L8BD9 fcn 'UL ' +; HEX$ function +HEXDOL jsr LB740 ; convert argument to positive integer + ldx #STRBUF+2 ; point to string buffer + ldb #4 ; convert 4 nibbles +L8BE5 pshs b ; save nibble counter + clrb ; clear digit accumulator + lda #4 ; do 4 shifts +L8BEA asl FPA0+3 ; shift a bit off the left of the value into low bits of B + rol FPA0+2 + rolb + deca ; done all shifts? + bne L8BEA ; brif not + tstb ; do we have a nonzero digit? + bne L8BFF ; brif so + lda ,s ; is it last digit? + deca + beq L8BFF ; brif so - keep the 0 + cmpx #STRBUF+2 ; is it a middle zero? + beq L8C0B ; brif not +L8BFF addb #'0 ; add ASCII bias + cmpb #'9 ; above 9? + bls L8C07 ; brif not + addb #7 ; adjust into alpha range +L8C07 stb ,x+ ; save digit in output + clr ,x ; make sure we have a NUL term +L8C0B puls b ; get back nibble counter + decb ; done all? + bne L8BE5 ; brif not + leas 2,s ; don't return mainline (we're returning a string) + ldx #STRBUF+1 ; point to start of converted number + jmp LB518 ; save string in string space, etc., and return it +; DLOAD command +DLOAD jsr LA429 ; close files +L8C1B jsr GETCCH ; get back input character + suba #'M ; is it DLOADM? + pshs a ; save DLOADM flag + bne L8C25 ; brif DLOAD + jsr GETNCH ; eat the "M" +L8C25 jsr LA578 ; parse the file name + jsr GETCCH ; get character after file name + beq L8C44 ; brif end of line + jsr SYNCOMMA ; make sure we have a comma + cmpa #', ; do we have 2 commas? + beq L8C44 ; brif so - use default baud rate + jsr EVALEXPB ; evaluate baud rate +L8C36 lda #44*4 ; delay for 300 baud + tstb ; was argument 0? + beq L8C42 ; brif so - 300 baud + lda #44 ; constant for 1200 baud + decb ; was it 1? + lbne LB44A ; raise error if not +L8C42 sta DLBAUD ; save baud rate constant +L8C44 jsr L8CD0 ; transmit file name and read in file status + pshs a ; save register + lda #-3 ; set input to DLOAD + sta DEVNUM + puls a ; restore register + tst ,s+ ; is it DLOADM? + beq L8C85 ; brif so + jsr LA5C7 ; check for end of line - error if not + tstb ; ASCII? + beq L8C5F ; brif not - do error + jsr LAD19 ; clear out program + jmp LAC7C ; go read program +L8C5F jmp LA616 ; raise bad file mode +; CLOADM patch for Extended Basic +L8C62 jsr GETNCH ; get character after CLOAD + cmpa #'M ; CLOADM? + lbne CLOAD ; brif not - Color Basic's CLOAD can handle it + clr FILSTA ; close tape file + jsr GETNCH ; eat the "M" + jsr LA578 ; parse file name + jsr LA648 ; find the file + tst CASBUF+10 ; is it a chunked file? + lbeq LA505 ; brif not - Color Basic's CLOADM can handle it + ldu CASBUF+8 ; get file type and ASCII flag + dec DEVNUM ; set source device to tape + jsr LA635 ; go read the first block + tfr u,d ; put type and ASCII flag somewhere more useful +; NOTE: DLOADM comes here to do the final processing +L8C85 subd #0x200 ; is it binary and "machine language"? + bne L8C5F ; brif not - raise an error + ldx ZERO ; default load offset + jsr GETCCH ; is there any offset? + beq L8C96 ; brif not + jsr SYNCOMMA ; make sure there's a comma + jsr LB73D ; evaluate offset in X +L8C96 stx VD3 ; save offset + jsr LA5C7 ; raise error if more stuff follows +L8C9B bsr L8CC6 ; get type of "amble" + pshs a ; save it + bsr L8CBF ; read in block length + tfr d,y ; save it + bsr L8CBF ; read in load address + addd VD3 ; add in offset + std EXECJP ; save it as the execution address + tfr d,x ; put load address in a pointer + lda ,s+ ; get "amble" type + lbne LA42D ; brif postamble - close file +L8CB1 bsr L8CC6 ; read a data byte + sta ,x ; save in memory + cmpa ,x+ ; did it actually save? + bne L8CCD ; brif not RAM - raise error + leay -1,y ; done yet? + bne L8CB1 ; brif not + bra L8C9B ; look for another "amble" +L8CBF bsr L8CC1 ; read a character to B +L8CC1 bsr L8CC6 ; read character to A + exg a,b ; swap character with previously read one +L8CC5 rts +L8CC6 jsr LA176 ; read a character from input + tst CINBFL ; EOF? + beq L8CC5 ; brif not +L8CCD jmp LA619 ; raise I/O error if EOF +L8CD0 bsr L8D14 ; transmit file name + pshs b,a ; save file status + inca ; was file found? + beq L8CDD ; brif not + ldu ZERO ; zero U - first block + bsr L8CE4 ; read block + puls a,b,pc ; restore status and return +L8CDD ldb #2*26 ; code for NE error + jmp LAC46 ; raise error +L8CE2 ldu CBUFAD ; get block number +L8CE4 leax 1,u ; bump block number + stx CBUFAD ; save new block number + ldx #CASBUF ; use cassette buffer + jsr L8D7C ; read a block + jmp LA644 ; reset input buffer pointers +; Generic input handler for Extended Basic +XVEC4 lda DEVNUM ; get device number + cmpa #-3 ; DLOAD? + bne L8D01 ; brif not + leas 2,s ; don't return to mainline code + clr CINBFL ; reset EOF flag to not EOF + tst CINCTR ; anything available? + bne L8D02 ; brif so - fetch one + com CINBFL ; flag EOF +L8D01 rts +L8D02 pshs u,y,x,b ; save registers + ldx CINPTR ; get buffer pointer + lda ,x+ ; get character from buffer + pshs a ; save it for return + stx CINPTR ; save new input pointer + dec CINCTR ; account for byte removed from buffer + bne L8D12 ; brif buffer not empty + bsr L8CE2 ; go read a block +L8D12 puls a,b,x,y,u,pc ; restore registers, return value, and return +L8D14 clra ; clear attempt counter + pshs x,b,a ; make a hole for variables + leay ,s ; set up frame pointer + bra L8D1D ; go read block +L8D1B bsr L8D48 ; bump attempt counter +L8D1D lda #0x8a ; send file request control code + bsr L8D58 + bne L8D1B ; brif no echo or error + ldx #CFNBUF+1 ; point to file name +L8D26 lda ,x+ ; get file name characater + jsr L8E04 ; send it + cmpx #CFNBUF+9 ; end of file name? + bne L8D26 ; brif not + bsr L8D62 ; output check byte and look for response + bne L8D1B ; transmit name again if not ack + bsr L8D72 ; get file type (0xff is not found) + bne L8D1B ; brif error + sta 2,y ; save file type + bsr L8D72 ; read ASCII flag + bne L8D1B ; brif error + sta 3,y ; save ASCII flag + bsr L8D6B ; read check byte + bne L8D1B ; brif error + leas 2,s ; lose attempt counter and check byte + puls a,b,pc ; return file type and ascii flag +L8D48 inc ,y ; bump attempt counter + lda ,y ; get new count + cmpa #5 ; done 5 times? + blo L8D6A ; brif not + lda #0xbc ; send abort code + jsr L8E0C + jmp LA619 ; raise an I/O error +L8D58 pshs a ; save compare character + bsr L8DB8 ; send character + bne L8D60 ; brif read error + cmpa ,s ; does it match? (set Z if good) +L8D60 puls a,pc ; restore character and return +L8D62 lda 1,y ; get XOR check byte + bsr L8DB8 ; send it and read + bne L8D6A ; brif read error + cmpa #0xc8 ; is it ack? (set Z if so) +L8D6A rts +L8D6B bsr L8D72 ; read character from rs232 + bne L8D6A ; brif error + lda 1,y ; get check byte + rts +L8D72 bsr L8DBC ; read a character from rs232 + pshs a,cc ; save result (and flags) + eora 1,y ; accumulate xor checksum + sta 1,y + puls cc,a,pc ; restore byte, flags, and return +L8D7C clra ; reset attempt counter + pshs u,y,x,b,a ; make a stack frame + asl 7,s ; split block number into two 7 bit chuncks + rol 6,s + lsr 7,s + leay ,s ; set up frame pointer + bra L8D8B +L8D89 bsr L8D48 ; bump attempt counter +L8D8B lda #0x97 ; send block request code + bsr L8D58 + bne L8D89 ; brif error + lda 6,y ; send out block number (high bits first) + bsr L8E04 + lda 7,y + bsr L8E04 + bsr L8D62 ; send check byte and get ack + bne L8D89 ; brif error + bsr L8D72 ; read block size + bne L8D89 ; brif read error + sta 4,y ; save character count + ldx 2,y ; get buffer pointer + ldb #128 ; length of data block +L8DA7 bsr L8D72 ; read a data byte + bne L8D89 ; brif error + sta ,x+ ; save byte in buffer + decb ; done a whole block? + bne L8DA7 ; brif not + bsr L8D6B ; read check byte + bne L8D89 ; brif error + leas 4,s ; lose attempt counter, check byte, and buffer pointer + puls a,b,x,pc ; return with character count in A, clean rest of stack +L8DB8 clr 1,y ; clear check byte + bsr L8E0C ; output character +L8DBC clra ; clear attempt counter + pshs x,b,cc ; save registers and interrupt status + orcc #0x50 ; disable interrupts + lda TIMOUT ; get timout delay (variable) + ldx ZERO ; get constant timeout value +L8DC5 bsr L8DE6 ; get RS232 status + bcc L8DC5 ; brif "space" - waiting for "mark" +L8DC9 bsr L8DE6 ; get RS232 status + bcs L8DC9 ; brif "mark" - waiting for "space" (start bit) + bsr L8DF9 ; delay for half of bit time + ldb #1 ; set bit probe + pshs b ; save it + clra ; reset data byte +L8DD4 bsr L8DF7 ; wait one bit time + ldb PIA1+2 ; get input bit to carry + rorb + bcc L8DDE ; brif "space" (0) + ora ,s ; merge bit probe in +L8DDE asl ,s ; shift bit probe over + bcc L8DD4 ; brif we haven't done 8 bits + leas 1,s ; remove bit probe + puls cc,b,x,pc ; restore interrupts, registers, and return +L8DE6 ldb PIA1+2 ; get RS232 value + rorb ; put in C + leax 1,x ; bump timeout + bne L8DF6 ; brif nonzero + deca ; did the number of waits expire? + bne L8DF6 ; brif not + leas 2,s ; don't return - we timed out + puls cc,b,x ; restore interrupts and registers + inca ; clear Z (A was zero above) +L8DF6 rts +L8DF7 bsr L8DF9 ; do first half of bit delay then fall through for second +L8DF9 pshs a ; save register + lda DLBAUD ; get baud rate constant +L8DFD brn L8DFD ; do nothing - delay + deca ; time expired? + bne L8DFD ; brif not + puls a,pc ; restore register and return +L8E04 pshs a ; save character to send + eora 1,y ; accumulate chechsum + sta 1,y + puls a ; get character back +L8E0C pshs b,a,cc ; save registers and interrupt status + orcc #0x50 ; disable interrupts + bsr L8DF7 ; do a bit delay + bsr L8DF7 ; do another bit delay + clr PIA1 ; set output to space (start bit) + bsr L8DF7 ; do a bit delay + ldb #1 ; bit probe start at LSB + pshs b ; save bitprobe +L8E1D lda 2,s ; get output byte + anda ,s ; see what our current bit is + beq L8E25 ; brif output is 0 + lda #2 ; set output to "marking" +L8E25 sta PIA1 ; send bit + bsr L8DF7 ; do a bit delay + asl ,s ; shift bit probe + bcc L8E1D ; brif not last bit + lda #2 ; set output to marking ("stop" bit) + sta PIA1 + leas 1,s ; lose bit probe + puls cc,a,b,pc ; restore registers, interrupts, and return +; PRINT USING +; This is a massive block of code for something that has limited utility. It is *almost* flexible enough to +; be truly useful outside of a narrow range of use cases. Indeed, this comes in at about 1/8 of the total +; Extended Color Basic ROM. +; +; This uses several variables: +; VD5: pointer to format string descriptor +; VD7: next print item flag +; VD8: right digit counter +; VD9: left digit counter (or length of string argument) +; VDA: status byte (bits as follows): +; 6: force comma +; 5: force leading * +; 4: floating $ +; 3: pre-sign +; 2: post-sign +; 0: scientific notation +L8E37 lda #1 ; set length to use to 1 + sta VD9 +L8E3B decb ; consume character from format string + jsr L8FD8 ; show error flag if flags set + jsr GETCCH ; get input character + lbeq L8ED8 ; brif end of line - bail + stb VD3 ; save remaining string length + jsr LB156 ; evaluate the argument + jsr LB146 ; error if numeric + ldx FPA0+2 ; get descriptor for argument + stx V4D ; save it for later + ldb VD9 ; get length counter to use + jsr LB6AD ; get B bytes of string space (do a LEFT$) + jsr LB99F ; print the formatted string + ldx FPA0+2 ; get formatted string descriptor + ldb VD9 ; get requested length + subb ,x ; see if we have any left over +L8E5F decb ; have we got the right width? + lbmi L8FB3 ; brif so - go process more + jsr LB9AC ; output a space + bra L8E5F ; go see if we're done yet +L8E69 stb VD3 ; save current format string counter and pointer + stx TEMPTR + lda #2 ; initial spaces count = 2 (for the two %s) + sta VD9 ; save length counter +L8E71 lda ,x ; get character in string + cmpa #'% ; is it the end of the sequence? + beq L8E3B ; brif so - display requested part of the strign + cmpa #0x20 ; space? + bne L8E82 ; brif not + inc VD9 ; bump spaces count + leax 1,x ; move format pointer forward + decb ; consume character + bne L8E71 ; brif not end of format string +L8E82 ldx TEMPTR ; restore format string pointer + ldb VD3 ; get back format string length + lda #'% ; show % as debugging aid +L8E88 jsr L8FD8 ; send error indicator if flags set + jsr PUTCHR ; output character + bra L8EB9 ; go process more format string +; PRINT extension for USING +XVEC9 cmpa #0xcd ; USING? + beq L8E95 ; brif so + rts ; return to mainline code +; This is the main entry point for PRINT USING +L8E95 leas 2,s ; don't return to the mainline code + jsr LB158 ; evaluate the format string + jsr LB146 ; error if numeric + ldb #'; ; make sure there's a ; after the string + jsr LB26F + ldx FPA0+2 ; get format string descriptor + stx VD5 ; save it for later + bra L8EAE ; process format string +L8EA8 lda VD7 ; is there a print item? + beq L8EB4 ; brif not + ldx VD5 ; get back format string descriptor +L8EAE clr VD7 ; reset next print item flag + ldb ,x ; get length of format string + bne L8EB7 ; brif string is non-null +L8EB4 jmp LB44A ; raise FC error +L8EB7 ldx 2,x ; point to start of string +L8EB9 clr VDA ; clear status (new item) +L8EBB clr VD9 ; clear left digit counter + lda ,x+ ; get character from format string + cmpa #'! ; ! (use first character of string)? + lbeq L8E37 ; brif so + cmpa #'# ; digit? + beq L8F24 ; brif so - handle numeric + decb ; consume format character + bne L8EE2 ; brif not done + jsr L8FD8 ; show a "+" if any flags set - indicates error at end of string + jsr PUTCHR ; output format string character +L8ED2 jsr GETCCH ; get current input character + bne L8EA8 ; brif not end of statement + lda VD7 ; get next item flag +L8ED8 bne L8EDD ; brif more print items + jsr LB958 ; do newline +L8EDD ldx VD5 ; point to format string descriptor + jmp LB659 ; remove from string stack, etc., if appropriate (and return) +L8EE2 cmpa #'+ ; is it + (pre-sign)? + bne L8EEF ; brif not + jsr L8FD8 ; send a "+" if flags set + lda #8 ; flag for pre-sign + sta VDA ; set flags + bra L8EBB ; go interpret some more stuff +L8EEF cmpa #'. ; decimal? + beq L8F41 ; brif so - numeric + cmpa #'% ; % (show string)? + lbeq L8E69 ; brif so + cmpa ,x ; do we have two identical characters? +L8EFB bne L8E88 ; brif not - invalid format character + cmpa #'$ ; double $? + beq L8F1A ; brif so - floating $ + cmpa #'* ; double *? + bne L8EFB ; brif not + lda VDA ; get status byte + ora #0x20 ; enable * padding + sta VDA + cmpb #2 ; is $$ the last two? + blo L8F20 ; brif so + lda 1,x ; is it $ after? + cmpa #'$ + bne L8F20 ; brif not + decb ; consume the "$" + leax 1,x + inc VD9 ; add to digit counter * pad + $ counter +L8F1A lda VDA ; indicate floating $ + ora #0x10 + sta VDA +L8F20 leax 1,x ; consume the second format character + inc VD9 ; add one more left place +L8F24 clr VD8 ; clear right digit counter +L8F26 inc VD9 ; bump left digit counter + decb ; consume character + beq L8F74 ; brif end of string + lda ,x+ ; get next format character + cmpa #'. ; decimal? + beq L8F4F ; brif so + cmpa #'# ; digit? + beq L8F26 ; brif so + cmpa #', ; comma flag? + bne L8F5A ; brif not + lda VDA ; set commas flag + ora #0x40 + sta VDA + bra L8F26 ; handle more characters to left of decimal +L8F41 lda ,x ; get character after . + cmpa #'# ; digit? + lbne L8E88 ; brif not - invalid + lda #1 ; set right digit counter to 1 (for the .) + sta VD8 + leax 1,x ; consume the . +L8F4F inc VD8 ; add one to right digit counter + decb ; consume character + beq L8F74 ; brif end of format string + lda ,x+ ; get another format character + cmpa #'# ; digit? + beq L8F4F ; brif so +L8F5A cmpa #0x5e ; up arrow? + bne L8F74 ; brif not + cmpa ,x ; two of them? + bne L8F74 ; brif not + cmpa 1,x ; three of them? + bne L8F74 ; brif not + cmpa 2,x ; four of them? + bne L8F74 ; brif not + cmpb #4 ; string actually has the characters? + blo L8F74 ; brif not + subb #4 ; consome them + leax 4,x + inc VDA ; set scientific notation bit +L8F74 leax -1,x ; back up input pointer + inc VD9 ; add one digit for pre-sign force + lda VDA ; is it pre-sign? + bita #8 + bne L8F96 ; brif so + dec VD9 ; undo pre-sign adjustment + tstb ; end of string? + beq L8F96 ; brif so + lda ,x ; get next character + suba #'- ; post sign force? + beq L8F8F ; brif so + cmpa #'+-'- ; plus? + bne L8F96 ; brif not + lda #8 ; trailing + is a pre-sign force +L8F8F ora #4 ; add in post sign flag + ora VDA ; merge with flags + sta VDA + decb ; consume character +L8F96 jsr GETCCH ; do we have an argument + lbeq L8ED8 ; brif not + stb VD3 ; save format string length + jsr LB141 ; evluate numeric expression + lda VD9 ; get left digit counter + adda VD8 ; add in right digit counter + cmpa #17 ; is it more than 16 digits + decimal? + lbhi LB44A ; brif so - this is a problem + jsr L8FE5 ; format value according to settings + leax -1,x ; move buffer pointer back + jsr STRINOUT ; display formatted number string +L8FB3 clr VD7 ; reset next print item flag + jsr GETCCH ; get current input character + beq L8FC6 ; brif end of statement + sta VD7 ; set next print flag to nonzero + cmpa #'; ; list separator ;? + beq L8FC4 ; brif so + jsr SYNCOMMA ; require a comma between if not ; + bra L8FC6 ; process next item +L8FC4 jsr GETNCH ; munch the semicolon +L8FC6 ldx VD5 ; get format string descriptor + ldb ,x ; get length of string + subb VD3 ; subtract amount left after last item + ldx 2,x ; point to string address + abx ; move pointer to correct spot + ldb VD3 ; get remaining string length + lbne L8EB9 ; if we have more, interpret from there + jmp L8ED2 ; re-interpret from start if we hit the end +L8FD8 pshs a ; save character + lda #'+ ; "error" flag character + tst VDA ; did we have some flags set? + beq L8FE3 ; brif not + jsr PUTCHR ; output error flag +L8FE3 puls a,pc ; restore character and return +L8FE5 ldu #STRBUF+4 ; point to string buffer + ldb #0x20 ; blank space + lda VDA ; get flags + bita #8 ; pre-sign? + beq L8FF2 ; brif not + ldb #'+ ; plus sign +L8FF2 tst FP0SGN ; get sign of value + bpl L8FFA ; brif positive + clr FP0SGN ; make number positive (for later) + ldb #'- ; negative sign +L8FFA stb ,u+ ; put sign in buffer + ldb #'0 ; put a zero there + stb ,u+ + anda #1 ; check scientific notation force + lbne L910D ; brif so + ldx #LBDC0 ; point to FP 1E+9 + jsr LBCA0 ; is it less? + bmi L9023 ; brif so + jsr LBDD9 ; convert FP number to string (we're doing scientific notation) +L9011 lda ,x+ ; advance pointer to end of string + bne L9011 +L9015 lda ,-x ; make a hole at the start + sta 1,x + cmpx #STRBUF+3 ; done yet? + bne L9015 ; brif not + lda #'% ; put "overflow" flag at start + sta ,x + rts +L9023 lda FP0EXP ; get exponent of value + sta V47 ; save it + beq L902C ; brif value is 0 + jsr L91CD ; convert to number with 9 significant figures to left of decimal +L902C lda V47 ; get base 10 exponent offset + lbmi L90B3 ; brif < 100,000,000 + nega ; get negative difference + adda VD9 ; add to number of left digits + suba #9 ; account for the 9 we actually have + jsr L90EA ; put leading zeroes in buffer + jsr L9263 ; initialize the decimal point and comma counters + jsr L9202 ; convert FPA0 to decimal ASCII in buffer + lda V47 ; get base 10 exponent + jsr L9281 ; put that many zeroes in buffer, stop at decimal point + lda V47 ; get base 10 exponent + jsr L9249 ; check for decimal + lda VD8 ; get right digit counter + bne L9050 ; brif we want stuff after decimal + leau -1,u ; delete decimal if not needed +L9050 deca ; subtract one place (for decimal) + jsr L90EA ; put zeroes in buffer (trailing) +L9054 jsr L9185 ; insert * padding, floating $, and post-sign + tsta ; was there a post sign? + beq L9060 ; brif not + cmpb #'* ; was first character a *? + beq L9060 ; brif so + stb ,u+ ; store the post sign +L9060 clr ,u ; make srue it's NUL terminated + ldx #STRBUF+3 ; point to start of buffer +L9065 leax 1,x ; move to next character + stx TEMPTR ; save it for later + lda VARPTR+1 ; get address of decimal point + suba TEMPTR+1 ; subtract out actual digits left of decimal + suba VD9 ; subtract out required left digits + beq L90A9 ; brif no padding needed + lda ,x ; get current character + cmpa #0x20 ; space? + beq L9065 ; brif so - advance pointer + cmpa #'* ; *? + beq L9065 ; brif so - advance pointer + clra ; zero on stack is end of data ponter +L907C pshs a ; save character on stack + lda ,x+ ; get next character + cmpa #'- ; minus? + beq L907C ; brif so + cmpa #'+ ; plus? + beq L907C ; brif so + cmpa #'$ ; $? + beq L907C ; brif so + cmpa #'0 ; zero? + bne L909E ; brif not + lda 1,x ; get character after 0 + bsr L90AA ; clear carry if number + bcs L909E ; brif not number +L9096 puls a ; get character off stack + sta ,-x ; put it back in string buffer + bne L9096 ; brif not - restore another + bra L9065 ; keep cleaning up buffer +L909E puls a ; get the character on the stack + tsta ; is it NUL? + bne L909E ; brif not + ldx TEMPTR ; get string buffer start pointer + lda #'% ; put error flag in front + sta ,-x +L90A9 rts +L90AA cmpa #'0 ; zero? + blo L90B2 ; brif not + suba #'9+1 ; set C if > "9" + suba #-('9+1) +L90B2 rts +L90B3 lda VD8 ; get right digit counter + beq L90B8 ; brif not right digits + deca ; account for decimal point +L90B8 adda V47 ; add base 10 exponent offset + bmi L90BD ; if >= 0, no shifts are required + clra ; force shift counter to 0 +L90BD pshs a ; save shift counter +L90BF bpl L90CB ; brif positive count + pshs a ; save shift counter + jsr LBB82 ; divide FPA0 by 10 (shift 1 digit to the right) + puls a ; get shift counter back + inca ; account for the shift + bra L90BF ; see if we're done yet +L90CB lda V47 ; get base 10 exponent offset + suba ,s+ ; account for adjustment + sta V47 ; save new exponent offset + adda #9 ; account for significant places + bmi L90EE ; brif we don't need zeroes to left + lda VD9 ; get left decimal counter + suba #9 ; account for significant figures + suba V47 ; subtract exponent offset + bsr L90EA ; output leading zeroes + jsr L9263 ; initialize decimal and comma counters + bra L90FF ; process remainder of digits +L90E2 pshs a ; save zero counter + lda #'0 ; insert a 0 + sta ,u+ + puls a ; get back counter +L90EA deca ; do we need more zeroes? + bpl L90E2 ; brif so + rts +L90EE lda VD9 ; get left digit counter + bsr L90EA ; put that many zeroes in + jsr L924D ; put decimal in buffer + lda #-9 ; figure out filler zeroes + suba V47 + bsr L90EA ; output required leader zeroes + clr V45 ; clear decimal pointer counter + clr VD7 ; clear comma counter +L90FF jsr L9202 ; decode FPA0 to decimal string + lda VD8 ; get right digit counter + bne L9108 ; brif there are right digits + ldu VARPTR ; point to decimal location of decimal +L9108 adda V47 ; add base 10 exponent + lbra L9050 ; add in leading astrisks, etc. +L910D lda FP0EXP ; get exponent of FPA0 + pshs a ; save it + beq L9116 ; brif 0 + jsr L91CD ; convert to number with 9 figures +L9116 lda VD8 ; get right digit counter + beq L911B ; brif no right digits + deca ; account for decimal point +L911B adda VD9 ; get left digit counter + clr STRBUF+3 ; use buffer byte as temporary storage + ldb VDA ; get status flags + andb #4 ; post-sign? + bne L9129 ; brif so + com STRBUF+3 ; flip byte if no post sign +L9129 adda STRBUF+3 ; subtract 1 if no post sign + suba #9 ; account for significant figures + pshs a ; save shift counter +L9130 bpl L913C ; brif no more shifts needed + pshs a ; save counter + jsr LBB82 ; divide by 10 (shift right one) + puls a ; get back counter + inca ; account for the shift + bra L9130 ; see if we need more +L913C lda ,s ; get original shift count + bmi L9141 ; brif shifting happened + clra ; flag for no shifting +L9141 nega ; calculate position of decimal (negate shift count, add left digit and post sign if needed) + adda VD9 ; add left digit counter + inca ; and post sign + adda STRBUF+3 + sta V45 ; save decimal counter + clr VD7 ; clear comma counter + jsr L9202 ; convert to decimal string + puls a ; get shift counter + jsr L9281 ; put the needed zeroes in + lda VD8 ; get right digit counter + bne L915A ; brif we want some + leau -1,u ; remove te decimal point +L915A ldb ,s+ ; get original exponent + beq L9167 ; brif it was 0 + ldb V47 ; get base 10 exponent + addb #9 ; account for significant figures + subb VD9 ; remove left digit count + subb STRBUF+3 ; add one if post sign +L9167 lda #'+ ; positive sign + tstb ; is base 10 exponent positive? + bpl L916F ; brif so + lda #'- ; negative sign + negb ; flip exponent +L916F sta 1,u ; put exponent sign + lda #'E ; put "E" and advance output pointer + sta ,u++ + lda #'0-1 ; initialize digit accumulator +L9177 inca ; bump digit + subb #10 ; are we at the right digit? + bcc L9177 ; brif not + addb #'0+10 ; add ASCII bias and undo extra subtraction + std ,u++ ; save exponent in buffer + clr ,u ; clear final byte in buffer + jmp L9054 ; insert *, $, etc. +L9185 ldx #STRBUF+4 ; point to start of result + ldb ,x ; get sign + pshs b ; save it + lda #0x20 ; default pad with spaces + ldb VDA ; get flags + bitb #0x20 ; padding with *? + puls b + beq L919E ; brif no padding + lda #'* ; pad with * + cmpb #0x20 ; do we have a blank? (positive) + bne L919E ; brif not + tfr a,b ; use pad character +L919E pshs b ; save first character +L91A0 sta ,x+ ; store padding + ldb ,x ; get next character + beq L91B6 ; brif end of string + cmpb #'E ; exponent? + beq L91B6 ; brif so - treat as 0 + cmpb #'0 ; zero? + beq L91A0 ; brif so - pad it + cmpb #', ; leading comma? + beq L91A0 ; brif so - pad it + cmpb #'. ; decimal? + bne L91BA ; brif so - don't put a 0 before it +L91B6 lda #'0 ; put a zero before + sta ,-x +L91BA lda VDA ; get status byte + bita #0x10 ; floating $? + beq L91C4 ; brif not + ldb #'$ ; stuff a $ in + stb ,-x +L91C4 anda #4 ; pre-sgn? + puls b ; get back first character + bne L91CC ; brif not + stb ,-x ; save leading character (sign) +L91CC rts +L91CD pshs u ; save buffer pointer + clra ; initial exponent offset is 0 +L91D0 sta V47 ; save exponent offset + ldb FP0EXP ; get actual exponent + cmpb #0x80 ; is value >= 1.0? + bhi L91E9 ; brif so + ldx #LBDC0 ; point to FP number 1E9 + jsr LBACA ; multiply by 1000000000 + lda V47 ; account for 9 shifts + suba #9 + bra L91D0 ; brif not there yet +L91E4 jsr LBB82 ; divide by 10 + inc V47 ; account for shift +L91E9 ldx #LBDBB ; point to 999999999 + jsr LBCA0 ; compare it + bgt L91E4 ; brif not in range yet +L91F1 ldx #LBDB6 ; point to 99999999.9 + jsr LBCA0 ; compare + bgt L9200 ; brif in range + jsr LBB6A ; multiply by 10 + dec V47 ; account for shift + bra L91F1 ; see if we're in range yet +L9200 puls u,pc ; restore buffer pointer and return +L9202 pshs u ; save buffer pointer + jsr LB9B4 ; add .5 (round off) + jsr LBCC8 ; convert to integer format + puls u ; restore buffer pointer + ldx #LBEC5 ; point to 32 bit powers of 10 (alternating signs) + ldb #0x80 ; intitial digit counter is 0 with 0x80 bias +L9211 bsr L9249 ; check for comma +L9213 lda FPA0+3 ; add a 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 ; set V if carry and sign differ + rolb + bvc L9213 ; brif we haven't "wrapped" + bcc L9235 ; brif subtracting + subb #10+1 ; take 9's complement if adding + negb +L9235 addb #'0-1 ; add in ASCII bias + leax 4,x ; move to next power + tfr b,a ; save digit + anda #0x7f ; mask off subtract flag + sta ,u+ ; save digit + comb ; toggle add/subtract + andb #0x80 + cmpx #LBEE9 ; done all places? + bne L9211 ; brif not + clr ,u ; but NUL at end +L9249 dec V45 ; at decimal? + bne L9256 ; brif not +L924D stu VARPTR ; save decimal point pointer + lda #'. ; insert decimal + sta ,u+ + clr VD7 ; clear comma counter + rts +L9256 dec VD7 ; do we need a comma? + bne L9262 ; brif not + lda #3 ; reset comma counter + sta VD7 + lda #', ; insert comma + sta ,u+ +L9262 rts +L9263 lda V47 ; get base 10 exponent offset + adda #10 ; account for significant figures + sta V45 ; save decimal counter + inca ; add one for decimal point +L926A suba #3 ; divide by 3, leave remainder in A + bcc L926A + adda #5 ; renormalize to range 1-3 + sta VD7 ; save comma counter + lda VDA ; get status + anda #0x40 ; commas wanted? + bne L927A ; brif not + sta VD7 ; clear comma counter +L927A rts +L927B pshs a ; save zeroes counter + bsr L9249 ; check for decimal + puls a ; get back counter +L9281 deca ; need a zero? + bmi L928E ; brif not + pshs a ; save counter + lda #'0 ; put a zero + sta ,u+ + lda ,s+ ; get back counter and set flags + bne L927B ; brif not done enough +L928E rts +; From here to the end of the Extended Basic ROM is the PMODE graphics system and related +; infrastructure with the exception of the PLAY command which shares some of its machinery +; with the DRAW command. +; +; Fetch screen address calculation routine address for the selected graphics mode +L928F ldu #L929C ; point to normalization routine jump table + lda PMODE ; get graphics mode + asla ; two bytes per address + ldu a,u ; get routine address + rts +; Normalize VERBEG/HORBEG coordinates and return screen address in X and pixel mask in A. +L9298 bsr L928F ; fetch normalization routine pointer + jmp ,u ; transfer control to it +L929C fdb L92A6 ; PMODE 0 + fdb L92C2 ; PMODE 1 + fdb L92A6 ; PMODE 2 + fdb L92C2 ; PMODE 3 + fdb L92A6 ; PMODE 4 +; Two colour mode address calculatoin +L92A6 pshs u,b ; savce registers + ldb HORBYT ; get number of bytes in each graphics row + lda VERBEG+1 ; get vertical coordinate + mul + addd BEGGRP ; now D is the absolute address of the start of the row + tfr d,x ; get address to the return location + ldb HORBEG+1 ; get horizontal coordinate + lsrb ; divide by 8 (8 pixels per byte in 2 colour mode) + lsrb + lsrb + abx ; now X is the address of the actual pixel byte + lda HORBEG+1 ; get horizontal coordinate + anda #7 ; keep only the low 3 bits which contain the pixel number + ldu #L92DD ; point to pixel mask lookup + lda a,u ; get pixel mask + puls b,u,pc ; restore registers and return result +; four colour address calculation +L92C2 pshs u,b ; save registers + ldb HORBYT ; get bytes per graphics row + lda VERBEG+1 ; get vertical coordinate + mul + addd BEGGRP ; now D is the address of the start of the row + tfr d,x ; put it in returnlocatin + ldb HORBEG+1 ; get horizontal coordinate + lsrb ; divide by 4 (four colour modes have four pixels per byte) + lsrb + abx ; now X points to the screen byte + lda HORBEG+1 ; get horizontal coordinate + anda #3 ; keep low two bits for pixel number + ldu #L92E5 ; point to four colour pixel masks + lda a,u ; get pixel mask + puls b,u,pc ; restore registers and return result +L92DD fcb 0x80,0x40,0x20,0x10 ; two colour pixel masks + fcb 0x08,0x04,0x02,0x01 +L92E5 fcb 0xc0,0x30,0x0c,0x03 ; four colour pixel masks +; Move X down one graphics row +L92E9 ldb HORBYT ; get bytes per row + abx ; add to screen address + rts +; Move one pixel right in 2 colour mode +L92ED lsra ; move pixel mask right + bcc L92F3 ; brif same byte + rora ; move pixel mask to left of byte + leax 1,x ; move to next byte +L92F3 rts +; Move one pixel right in 4 colour mode +L92F4 lsra ; shift mask half a pixel right + bcc L92ED ; brif not past end of byte - shift one more + lda #0xc0 ; set mask on left of byte + leax 1,x ; move to next byte + rts +; Evaluate two expressions (coordinates). Put first in HORBEG and second in VERBEG. +L92FC jsr LB734 ; evaluate two expressions - first in BINVAL, second in B + ldy #HORBEG ; point to storage location +L9303 cmpb #192 ; is vertical outside range? + blo L9309 ; brif not + ldb #191 ; max it at bottom of screen +L9309 clra ; zero extend vertical coordinate + std 2,y ; save vertical coordinate + ldd BINVAL ; get horizontal coordinate + cmpd #256 ; in range? + blo L9317 ; brif so + ldd #255 ; max it out to right side of screen +L9317 std ,y ; save horizontal coordinate + rts +; Normalize coordinates for proper PMODE +L931A jsr L92FC ; parse coordinates +L931D ldu #HORBEG ; point to start coordinates +L9320 lda PMODE ; get graphics mode + cmpa #2 ; is it pmode 0 or 1? + bhs L932C ; brif not + ldd 2,u ; get vertical coordinate + lsra ; divide it by two + rorb + std 2,u ; save it back +L932C lda PMODE ; get graphics mode + cmpa #4 ; pmode 4? + bhs L9338 ; brif so + ldd ,u ; cut horizontal coordinate in half + lsra + rorb + std ,u ; save new coordinate +L9338 rts +; PPOINT function +PPOINT jsr L93B2 ; evaluate two expressions (coordinates) + jsr L931D ; normalize coordinates + jsr L9298 ; get screen address + anda ,x ; get colour value of desired screen coordinate + ldb PMODE ; get graphics mode + rorb ; is it a two colour m ode? + bcc L935B ; brif so +L9349 cmpa #4 ; is it on rightmost bits? + blo L9351 ; brif not + rora ; shift right + rora + bra L9349 ; see if we're there yet +L9351 inca ; colour numbers start at 1 + asla ; add in colour set (0 or 8) + adda CSSVAL + lsra ; get colour in range of 0 to 8 +L9356 tfr a,b ; put result to B + jmp LB4F3 ; return B as FP number +L935B tsta ; is pixel on? + beq L9356 ; brif not, return 0 (off) + clra ; set colour number to "1" + bra L9351 ; make it 1 or 5 and return +; PSET command +PSET lda #1 ; PSET flag + bra L9366 ; go turn on the pixel +; PRESET command +PRESET clra ; PRESET flag +L9366 sta SETFLG ; store whether we're setting or resetting + jsr LB26A ; enforce ( + jsr L931A ; evaluate coordinates + jsr L9581 ; evaluate colour + jsr LB267 ; enforce ) + jsr L9298 ; get address of pixel +L9377 ldb ,x ; get screen data + pshs b ; save it + tfr a,b ; duplicate pixel mask + coma ; invert mask + anda ,x ; turn off screen pixel + andb ALLCOL ; adjust pixel mask to be the current colour + pshs b ; merge pixel data into the screen data + ora ,s+ + sta ,x ; put it on screen + suba ,s+ ; nonzero if screen data changed + ora CHGFLG ; propagate change flag + sta CHGFLG + rts +; Evaluate two sets of coordinates separated by a minus sign. First at HORBEG,VERBEG and +; second at HOREND,VEREND. If no first set, use HORDEF,VERDEF. +L938F ldx HORDEF ; set default start coords + stx HORBEG + ldx VERDEF + stx VERBEG + cmpa #0xac ; do we start with a -? + beq L939E ; brif no starting coordinates + jsr L93B2 ; parse coordinates +L939E ldb #0xac ; make sure we have a - + jsr LB26F + jsr LB26A ; require a ( + jsr LB734 ; evaluate two expressions + ldy #HOREND ; point to storage location + jsr L9303 ; process coordinates + bra L93B8 ; finish up with a ) +L93B2 jsr LB26A ; make sure there's a ( + jsr L92FC ; evaluate coordinates +L93B8 jmp LB267 ; force a ) +; LINE command +LINE cmpa #0x89 ; is it LINE INPUT? + lbeq L89C0 ; brif so - go handle it + cmpa #'( ; starting coord? + beq L93CE ; brif so + cmpa #0xac ; leading -? + beq L93CE ; brif so + ldb #'@ ; if it isn't the above, make sure it's @ + jsr LB26F +L93CE jsr L938F ; parse coordinates + ldx HOREND ; set ending coordinates as the defaults + stx HORDEF + ldx VEREND + stx VERDEF + jsr SYNCOMMA ; make sure we have a comma + cmpa #0xbe ; PRESET? + beq L93E9 ; brif so + cmpa #0xbd ; PSET? + lbne LB277 ; brif not + ldb #01 ; PSET flag + skip1lda ; skip byte and set A nonzero +L93E9 clrb ; PRESET flag + pshs b ; save PSET/PRESET flag + jsr GETNCH ; eat the PSET/PRESET + jsr L9420 ; normalize coordinates + puls b ; get back PSET/PRESET flag + stb SETFLG ; flag which we're doing + jsr L959A ; set colour byte + jsr GETCCH ; get next bit + lbeq L94A1 ; brif no box option + jsr SYNCOMMA ; make sure it's comma + ldb #'B ; make sure "B" for "box" + jsr LB26F + bne L9429 ; brif something follows the B + bsr L9444 ; draw horizontal line + bsr L946E ; draw vertical line + ldx HORBEG ; save horizontal coordinate + pshs x ; save it + ldx HOREND ; switch in horizontal end + stx HORBEG + bsr L946E ; draw vertical line + puls x ; get back original start + stx HORBEG ; put it back + ldx VEREND ; do the same dance with the vertical end + stx VERBEG + bra L9444 ; draw horizontal line +L9420 jsr L931D ; normalize the start coordinates + ldu #HOREND ; point to end coords + jmp L9320 ; normalize those coordinates +L9429 ldb #'F ; make sure we have "BF" for "filled box" + jsr LB26F + bra L9434 ; fill the box +L9430 leax -1,x ; move vertical coordinate up one +L9432 stx VERBEG ; save new vertical coordinate +L9434 jsr L9444 ; draw a horizontal line + ldx VERBEG ; are we at the end of the box? + cmpx VEREND + beq L9443 ; brif so + bcc L9430 ; brif we're moving up the screen + leax 1,x ; move down the screen + bra L9432 ; go draw another line +L9443 rts +; Draw a horizontal line from HORBEG to HOREND at VERBEG using color mask in ALLCOL +L9444 ldx HORBEG ; get starting horizontal coordinate + pshs x ; save it + jsr L971D ; get absolute value of HOREND-HORBEG + bcc L9451 ; brif end is > start + ldx HOREND ; copy end coordinate to start it is smaller + stx HORBEG +L9451 tfr d,y ; save difference - it's a pixel count + leay 1,y ; coordinates are inclusive + jsr L9298 ; get screen position of start coord + puls u ; restore original start coordinate + stu HORBEG + bsr L9494 ; point to routine to move pizel pointers to right +L945E sta VD7 ; save pixel mask + jsr L9377 ; turn on pixel + lda VD7 ; get pixel mask back + jsr ,u ; move one pixel right + leay -1,y ; turned on enough pixels yet? + bne L945E ; brif not +L946B rts +L946C puls b,a ; clean up stack +L946E ldd VERBEG ; save original vertical start coordinate + pshs b,a + jsr L9710 ; get vertical difference + bcc L947B ; brif end coordinate > start + ldx VEREND ; swap in end coordinate if not + stx VERBEG +L947B tfr d,y ; save number of pixels to set + leay 1,y ; the coordinates are inclusive + jsr L9298 ; get screen pointer + puls u ; restore start coordinate + stu VERBEG + bsr L949D ; point to routine to move down one row + bra L945E ; draw vertical line +; Point to routine which will move one pixel right +L948A fdb L92ED ; PMODE 0 + fdb L92F4 ; PMODE 1 + fdb L92ED ; PMODE 2 + fdb L92F4 ; PMODE 3 + fdb L92ED ; PMODE 4 +L9494 ldu #L948A ; point to jump table + ldb PMODE ; get graphics mode + aslb ; two bytes per address + ldu b,u ; get jump address + rts +; Point to routine to move down one row +L949D ldu #L92E9 ; point to "move down one row" routien + rts +; Draw a line from HORBEG,VERBEG to HOREND,VEREND +L94A1 ldy #L950D ; point to increase vertical coord + jsr L9710 ; calculate difference + lbeq L9444 ; brif none - draw a horizontal line + bcc L94B2 ; brif vertical end is > vertical start + ldy #L951B ; point to decrease vertical coord +L94B2 pshs d ; save vertical difference + ldu #L9506 ; point to increase horizontal coord + jsr L971D ; get difference + beq L946C ; brif none - draw a vertical line + bcc L94C1 ; brif horizontal end > horizontal start + ldu #L9514 ; point to decrease hoizontal coord +L94C1 cmpd ,s ; compare vert and horiz differences + puls x ; get X difference + bcc L94CC ; brif horiz diff > vert diff + exg u,y ; swap change routine pointers + exg d,x ; swap differences +L94CC pshs u,d ; save larger difference and routine + pshs d ; save larger difference + lsra ; divide by two + rorb + bcs L94DD ; brif odd number + cmpu #L950D+1 ; increase or decrease? + blo L94DD ; brif increase + subd #1 ; back up one +L94DD pshs x,b,a ; save smallest difference and initial middle offset + jsr L928F ; point to proper coordinate to screen conversion routine +L94E2 jsr ,u ; convert coordinates to screen address + jsr L9377 ; turn on a pixel + ldx 6,s ; get distnace counter + beq L9502 ; brif line is completely drawn + leax -1,x ; account for one pixel drawn + stx 6,s ; save new counter + jsr [8,s] ; increment/decrement larger delta + ldd ,s ; get the minor coordinate increment counter + addd 2,s ; add the smallest difference + std ,s ; save new minor coordinate incrementcounter + subd 4,s ; subtractout the largest difference + bcs L94E2 ; brif not greater - draw another pixel + std ,s ; save new minor coordinate increment + jsr ,y ; adjust minor coordinate + bra L94E2 ; go draw another pixel +L9502 puls x ; clean up stack and return + puls a,b,x,y,u,pc +L9506 ldx HORBEG ; bump horizontal coordinate + leax 1,x + stx HORBEG + rts +L950D ldx VERBEG ; bump vertical coordinate + leax 1,x + stx VERBEG + rts +L9514 ldx HORBEG ; decrement horizontal coordinate + leax -1,x + stx HORBEG + rts +L951B ldx VERBEG ; decrement vertical coordinate + leax -1,x + stx VERBEG + rts +; Get normalized maximum coordinate values in VD3 and VD5 +L9522 ldu #VD3 ; point to temp storage + ldx #255 ; set maximum horizontal + stx ,u + ldx #191 ; set maximum vertical + stx 2,u + jmp L9320 ; normalize them +; PCLS command +PCLS beq L9542 ; clear to background colour if no argument + bsr L955A ; evaluate colour +L9536 lda #0x55 ; consider each byte as 4 groups of 2 bit sub-nibbles + mul ; now colour is in all four sub-pixels + ldx BEGGRP ; get start of graphics screen +L953B stb ,x+ ; set byte to proper colour + cmpx ENDGRP ; at end of graphics page? + bne L953B ; brif not + rts +L9542 ldb BAKCOL ; get background colour + bra L9536 ; do the clearing dance +; COLOR command +COLOR cmpa #', ; check for comma + beq L9552 ; brif no foreground colour + bsr L955A ; evaluate first colour + stb FORCOL ; set foreground colour + jsr GETCCH ; is there a background colour? + beq L9559 ; brif not +L9552 jsr SYNCOMMA ; make sure we have a comma + bsr L955A ; evaluate background colour argument + stb BAKCOL ; set background colour +L9559 rts +; Evaluate a colour agument and convert to proper code based on graphics mode +L955A jsr EVALEXPB ; evaluate colour code +L955D cmpb #9 ; is it in range of 0-8? + lbhs LB44A ; brif not - raise error + clra ; CSS value for first colour set + cmpb #5 ; is it first or second colour set? + blo L956C ; brif first colour set + lda #8 ; flag second colour set + subb #4 ; adjust into basic range +L956C pshs a ; save CSS value + lda PMODE ; get graphics mode + rora ; 4 colour or 2? + bcc L957B ; brif 2 colour + tstb ; was it 0? + bne L9578 ; brif not +L9576 ldb #4 ; if so, make it 4 +L9578 decb ; convert to zero based +L9579 puls a,pc ; get back CSS value and return +L957B rorb ; is colour number odd? + bcs L9576 ; brif so - force all bits set colour + clrb ; force colour 0 if not + bra L9579 +; Set all pixel byte and active colour +L9581 jsr L959A ; set colour byte + jsr GETCCH ; is there something to evaluate? + beq L9598 ; brif not + cmpa #') ; )? + beq L9598 ; brif so + jsr SYNCOMMA ; force comma + cmpa #', ; another comma? + beq L9598 ; brif so + jsr L955A ; evaluate expression and return colour + bsr L95A2 ; save colour and pixel byte +L9598 jmp GETCCH ; re-fetch input character and return +L959A ldb FORCOL ; use foreground colour by default + tst SETFLG ; doing PRESET? + bne L95A2 ; brif not + ldb BAKCOL ; default to background colour +L95A2 stb WCOLOR ; save working colour + lda #0x55 ; consider a byte as 4 pixels + mul ; now all pixels are set to the same bit pattern + stb ALLCOL ; set all pixels byte + rts +L95AA bne L95CF ; brif graphics mode +L95AC pshs x,b,a ; save registers + ldx #SAMREG+8 ; point to middle of control register + sta 10,x ; reset display page to 0x400 + sta 8,x + sta 6,x + sta 4,x + sta 2,x + sta 1,x + sta -2,x + sta -4,x ; reset to alpha mode + sta -6,x + sta -8,x + lda PIA1+2 ; set VDG to alpha mode, colour set 0 + anda #7 + sta PIA1+2 + puls a,b,x,pc ;restore registers and return +L95CF pshs x,b,a ; save registers + lda PMODE ; get graphics mode + adda #3 ; offset to 3-7 (we don't use the bottom 3 modes) + ldb #0x10 ; shift to high 4 bits + mul + orb #0x80 ; set to graphics mode + orb CSSVAL ; set the desired colour set + lda PIA1+2 ; get get original PIA values + anda #7 ; mask off VDG control + pshs a ; merge with new VDG control + orb ,s+ + stb PIA1+2 ; set new VDG mode + lda BEGGRP ; get start of graphics page + lsra ; divide by two - pages are on 512 byte boundaries + jsr L960F ; set SAM control register + lda PMODE ; get graphics mode + adda #3 ; shift to VDG values + cmpa #7 ; PMODE 4? + bne L95F7 ; brif not + deca ; treat PMODE 4 the same as PMODE 3 +L95F7 bsr L95FB ; program SAM's VDG bits + puls a,b,x,pc ; restore registers and return +L95FB ldb #3 ; set 3 bits in register + ldx #SAMREG ; point to VDG control bits +L9600 rora ; get bit to set + bcc L9607 ; brif we need to clear the bit + sta 1,x ; set the bit + bra L9609 +L9607 sta ,x ; clear the bit +L9609 leax 2,x ; move to next bit + decb ; done all bits? + bne L9600 ; brif not + rts +L960F ldb #7 ; 7 screen address bits + ldx #SAMREG+6 ; point to screen address bits in SAM + bra L9600 ; go program SAM bits +L9616 lda PIA1+2 ; get VDG bits + anda #0xf7 ; keep everything but CSS bit + ora CSSVAL ; set correct CSS bit + sta PIA1+2 ; set desired CSS + rts +; PMODE command +PMODETOK cmpa #', ; is first argument missing? + beq L9650 ; brif so + jsr EVALEXPB ; evaluate PMODE number + cmpb #5 ; valid (0-4)? + bhs L966D ; brif not + lda GRPRAM ; get start of graphics memory +L962E sta BEGGRP ; set start of graphics page + aslb ; multiply mode by two (table has two bytes per entry) + ldu #L9706+1 ; point to lookup table + adda b,u ; add in number of 256 byte pages used for graphics screen + cmpa TXTTAB ; does it fit? + bhi L966D ; brif not + sta ENDGRP ; save end of graphics + leau -1,u ; point to bytes per horizontal row + lda b,u ; get bytes per row + sta HORBYT ; set it + lsrb ; restore PMODE value + stb PMODE ; set graphics mode + clra ; set background colour to 0 + sta BAKCOL + lda #3 ; set foreground colour to maximum (3) + sta FORCOL + jsr GETCCH ; is there a starting page number? + beq L966C ; brif not +L9650 jsr LB738 ; evaluate an expression following a comma + tstb ; page 0? + beq L966D ; brif so - not valid + decb ; zero-base it + lda #6 ; each graphics page is 6*256 + mul + addb GRPRAM ; add to start of graphics memory + pshs b ; save start of screen memory + addb ENDGRP ; add current and address + subb BEGGRP ; subtract current start (adds size of screen) + cmpb TXTTAB ; does it fit? + bhi L966D ; brif not + stb ENDGRP ; save new end of graphics + puls b ; get back start of graphics + stb BEGGRP ; set start of graphics +L966C rts +L966D jmp LB44A ; raise FC error +; SCREEN command +SCREEN cmpa #', ; is there a mode? + beq L967F ; brif no mode + jsr EVALEXPB ; get mode argument + tstb ; set Z if alpha + jsr L95AA ; set SAM/VDG for graphics mode + jsr GETCCH ; is there a second argument? + beq L966C ; brif not +L967F jsr LB738 ; evaluate ,<expr> + tstb ; colour set 0? + beq L9687 ; brif so + ldb #8 ; flag for colour set 1 +L9687 stb CSSVAL ; set colour set + bra L9616 ; set up VDG +; PCLEAR command +PCLEAR jsr EVALEXPB ; evaulate number of pages requested + tstb ; 0? + beq L966D ; brif zero - not allowed + cmpb #9 ; more than 8? + bhs L966D ; brif so - not allowed + lda #6 ; there are 6 "pages" per graphics page + mul ; now B is the number of pages to reserve + addb GRPRAM ; add to start of graphics memory + tfr b,a ; now A is the MSB of the start of free memory + ldb #1 ; program memory always starts one above + tfr d,y ; save pointer to program memory + cmpd ENDGRP ; are we trying to deallocate the current graphics page? + blo L966D ; brif so (note that this prevents PCLEAR 0 anyway) + subd TXTTAB ; subtract out current start of basic program + addd VARTAB ; add in end of program - now D is new top of program + tfr d,x ; save new end of program + inca ; make some extra space (for stack) + subd FRETOP ; see if new top of program fits + bhs L966D ; brif there isn't enough space + jsr L80D0 ; adjust input pointer + nop ; space filler for 1.1 patch (the JSR above) + ldu VARTAB ; get end of program + stx VARTAB ; save new end of program + cmpu VARTAB ; is old end higher? + bhs L96D4 ; brif so +L96BD lda ,-u ; copy a byte upward + sta ,-x + cmpu TXTTAB ; at beginning? + bne L96BD ; brif not + sty TXTTAB ; save new start of program + clr -1,y ; there must always be a NUL before the program +L96CB jsr LACEF ; re-assign basic program addresses + jsr LAD26 ; reset variables and stack + jmp LAD9E ; return to interpretation loop +L96D4 ldu TXTTAB ; get start of program + sty TXTTAB ; save new start of program + clr -1,y ; there must be a NUL at the start of the program +L96DB lda ,u+ ; move a byte downward + sta ,y+ + cmpy VARTAB ; at the top of the program? + bne L96DB ; brif not + bra L96CB ; finish up +; Graphics initialization routine - this really should be up at the start of the ROM with the +; rest of the initialization code. +L96E6 ldb #0x1e ; set start of program to 0x1e00 ("PCLEAR 4") + stb TXTTAB + lda #6 ; graphics memory starts immediately after the screen +L96EC sta GRPRAM ; set graphics memory start + sta BEGGRP ; set start of current graphics page + clra ; set PMODE to 0 + sta PMODE + lda #16 ; 16 bytes per graphics row + sta HORBYT + lda #3 ; set foreground colour to 3 + sta FORCOL + lda #0x0c ; set ending graphics page (for PMODE 0) + sta ENDGRP + ldx TXTTAB ; get start of program + clr -1,x ; make sure there's a NUL before it +L9703 jmp LAD19 ; do a "NEW" +; PMODE data table (bytes per row and number of 256 byte pages required for a screen) +L9706 fcb 16,6 ; PMODE 0 + fcb 32,12 ; PMODE 1 + fcb 16,12 ; PMODE 2 + fcb 32,24 ; PMODE 3 + fcb 32,24 ; PMODE 4 +; Calculate absolute value of vertical coordinate difference +L9710 ldd VEREND ; get ending address + subd VERBEG ; get difference +L9714 bcc L9751 ; brif we didn't carry + pshs cc ; save status (C set if start > end) + jsr L9DC3 ; negate the difference to be positive + puls cc,pc ; restore C and return +; Calculate absolute value of horizontal coordinate difference +L971D ldd HOREND ; get end coordinate + subd HORBEG ; calculate difference + bra L9714 ; turn into absolute value +; PCOPY command +PCOPY bsr L973F ; fetch address of the source page + pshs d ; save address + ldb #0xa5 ; make sure we have TO + jsr LB26F + bsr L973F ; fetch address of the second page + puls x ; get back source + tfr d,u ; put destination into a pointer + ldy #0x300 ; 0x300 words to copy +L9736 ldd ,x++ ; copy a word + std ,u++ + leay -1,y ; done? + bne L9736 ; brif not + rts +L973F jsr EVALEXPB ; evaluate page number + tstb ; zero? + beq L9752 ; brif invalid page number +; BUG: this should be deferred until after the address is calculated at which point it should +; be bhs instead of bhi. There should also be a check to make sure the page number is less than +; or equal to 8 above so we don't have to test for overflows below. + cmpb TXTTAB ; is page number higher than start of program (BUG!) + bhi L9752 ; brif so - error + decb ; zero-base the page number + lda #6 ; 6 "pages" per graphics page + mul ; now we have proper number of "pages" for the offset + addb GRPRAM ; add start of graphics memory + exg a,b ; put MSB into A, 0 into B. +L9751 rts +L9752 jmp LB44A ; raise illegal function call +; GET command +GET clrb ; GET flag + bra L975A ; go on to the main body +PUT ldb #1 ; PUT flag +L975A stb VD8 ; save GET/PUT flag + jsr RVEC22 ; do the RAM hook dance (so Disk Basic can do its thing) +L975F cmpa #'@ ; @ before coordinates? + bne L9765 ; brif not + jsr GETNCH ; eat the @ +L9765 jsr L938F ; evaluate start/end coordinates + jsr SYNCOMMA ; make sure we have a comma + jsr L98CC ; get pointer to array + tfr X,D ; save descriptor pointer + ldu ,x ; get offset to next descriptor + leau -2,u ; move back to array name + leau d,u ; point to end of array + stu VD1 ; save end of data + leax 2,x ; point to number of dimensions + ldb ,x ; get dimension count + aslb ; two bytes per dimension size + abx ; now X points to start of data + stx VCF ; save start of array data + lda VALTYP ; is it numeric + bne L9752 ; brif not + clr VD4 ; set default graphic action to PSET + jsr GETCCH ; get input character + beq L97B7 ; brif no action flag + com VD4 ; flag action enabled + jsr SYNCOMMA ; make sure there's a comma + tst VD8 ; PUT? + bne L979A ; brif so + ldb #'G ; check for full graphics option + jsr LB26F + bra L97CA ; handle the rest of the process +L979A ldb #5 ; 5 legal actions for PUT + ldx #L9839 ; point to action table +L979F ldu ,x++ ; get "clear bit" action routine + ldy ,x++ ; get "set bit" action routine + cmpa ,x+ ; does token match? + beq L97AE ; brif so + decb ; checked all? + bne L979F ; brif not + jmp LB277 ; raise error +L97AE sty VD5 ; save set bit action address + stu VD9 ; save clear bit action address + jsr GETNCH ; munch the acton token + bra L97CA ; handle rest of process +L97B7 ldb #0xf8 ; mask for bottom three bits + lda PMODE ; get graphics mode + rora ; odd number mode? + bcc L97C0 ; brif even + ldb #0xfc ; bottom 2 bits mask +L97C0 tfr b,a ; save mask + andb HORBEG+1 ; round down the start address + stb HORBEG+1 + anda HOREND+1 ; round down end address + sta HOREND+1 +L97CA jsr L971D ; get horizontal size + bcc L97D3 ; brif end > start + ldx HOREND ; switch end in for start + stx HORBEG +L97D3 std HOREND ; save size + jsr L9710 ; calculate vertical size + bcc L97DE ; brif end > start + ldx VEREND ; swap in vertical end for the start + stx VERBEG +L97DE std VEREND ; save vertical size + lda PMODE ; get graphics mode + rora ; even? + ldd HOREND ; get difference + bcc L97EB ; brif even (2 colour) + addd HOREND ; add in size (double it) + std HOREND ; save adjusted end size +L97EB jsr L9420 ; normalize differences + ldd HOREND ; get end coord + ldx VEREND ; get end size + leax 1,x ; make vertical size inclusive + stx VEREND ; save it back + tst VD4 ; got "G" or GET action + bne L9852 ; brif given + lsra ; we're going for whole bytes here + rorb + lsra + rorb + lsra + rorb + addd #1 ; make it inclusive + std HOREND ; save new coordinate + jsr L9298 ; convert to screen address +L9808 ldb HOREND+1 ; get horizontal size + pshs x ; save screen position +L980C tst VD8 ; get/put flag + beq L9831 ; brif get + bsr L9823 ; bump array data pointer + lda ,u ; copy data from array to screen + sta ,x+ +L9816 decb ; are we done the row? + bne L980C ; brif not + puls x ; get screen address + jsr L92E9 ; move to next row + dec VEREND+1 ; done? + bne L9808 ; brif not +L9822 rts +L9823 ldu VCF ; get array data location + leau 1,u ; bump it + stu VCF ; save new array data location + cmpu VD1 ; did we hit the end of the array? + bne L9822 ; brif not +L982E jmp LB44A ; raise function call error +L9831 lda ,x+ ; get data from screen + bsr L9823 ; bump array data pointer + sta ,u ; put data in array + bra L9816 ; do the loopy thing +; PUT actions +L9839 fdb L9894,L989B ; PSET + fcb 0xbd + fdb L989B,L9894 ; PRESET + fcb 0xbe + fdb L98B1,L989B ; OR + fcb 0xb1 + fdb L9894,L98B1 ; AND + fcb 0xb0 + fdb L98A1,L98A1 ; NOT + fcb 0xa8 +L9852 addd #1 ; add to horiz difference + std HOREND ; save it + lda VD8 ; PUT? + bne L9864 ; brif so + ldu VD1 ; get end of array +L985D sta ,-u ; zero out a byte + cmpu VCF ; done? + bhi L985D ; brif not +L9864 jsr L9298 ; get screen address + ldb PMODE ; get graphics mode + rorb ; even? + bcc L986E ; brif so + anda #0xaa ; use as pixel mask for 4 colour mode +L986E ldb #1 ; set bit probe + ldy VCF ; point to start of array data +L9873 pshs x,a ; save screen address + ldu HOREND ; get horizontal size +L9877 pshs u,a ; save horizontal size and pixel mask + lsrb ; move bit probe right + bcc L9884 ; brif we didn't fall off a byte + rorb ; shift carry back in on the left + leay 1,y ; move ahead a byte in the array + cmpy VD1 ; end of array data? + beq L982E ; raise error if so +L9884 tst VD8 ; PUT? + beq L98A7 ; brif not + bitb ,y ; test bit in array + beq L9890 ; brif not set + jmp [VD5] ; do action routine for bit set +L9890 jmp [VD9] ; do action routine for bit clear +L9894 coma ; invert mask + anda ,x ; read screen data and reset the desired bit + sta ,x ; save on screen + bra L98B1 +L989B ora ,x ; merge pixel mask with screen data (turn on bit) + sta ,x ; save on screen + bra L98B1 +L98A1 eora ,x ; invert the pixel in the screen data + sta ,x ; save on screen + bra L98B1 +L98A7 bita ,x ; is the bit set? + beq L98B1 ; brif not - do nothing + tfr b,a ; get bit probe + ora ,y ; turn on proper bit in data + sta ,y +L98B1 puls a,u ; get back array address + jsr L92ED ; move screen address to the right + leau -1,u ; account for consumed pixel + cmpu ZERO ; done yet? + bne L9877 ; brif not + ldx 1,s ; get start of row back + lda HORBYT ; get number of bytes per row + leax a,x ; move ahead one line + puls a ; get back screen pixel mask + leas 2,s ; lose the screen pointer + dec VEREND+1 ; done all rows? + bne L9873 ; brif not + rts +L98CC jsr LB357 ; evaluate a variable + ldb ,-x ; get variable name + lda ,-x + tfr d,u ; save it + ldx ARYTAB ; get start of arrays +L98D7 cmpx ARYEND ; end of arrays? + lbeq LB44A ; brif not found + cmpu ,x ; correct variable? + beq L98E8 ; brif so + ldd 2,x ; get array size + leax d,x ; move to next array + bra L98D7 ; check this array +L98E8 leax 2,x ; move pointer to the array header + rts ; obviously this rts is not needed +L98EB rts +; PAINT command +PAINT cmpa #'@ ; do we have @ before coords? + bne L98F2 ; brif not + jsr GETNCH ; eat the @ +L98F2 jsr L93B2 ; evaluate coordinates + jsr L931D ; normalize coordinates + lda #1 ; PSET flag (use working colour) + sta SETFLG + jsr L9581 ; parse colour and set working colour, etc. + ldd WCOLOR ; get working colour and all pixels byte + pshs d ; save them + jsr GETCCH ; is there anything else? + beq L990A ; brif not + jsr L9581 ; evaluate border colour +L990A lda ALLCOL ; get border colour all pixel byte + sta VD8 ; save border colour pixel byte + puls d ; get back working colour details + std WCOLOR + clra ; store a "stop" frame on the stack so PAINT knows when it's finished unwinding + pshs u,x,b,a + jsr L9522 ; set up starting coordinates + jsr L928F ; point to pixel mask routine + stu VD9 ; save pixel mask routine + jsr L99DF ; paint from current horizontal coordinate to zero (left) + beq L9931 ; brif hit border immediately + jsr L99CB ; paint from current horizontal coordinate upward (right) + lda #1 ; set direction to "down" + sta VD7 + jsr L99BA ; save "down" frame + neg VD7 ; set direction to "up" + jsr L99BA ; save "up" frame +L9931 sts TMPSTK ; save stack pointer +L9934 tst CHGFLG ; did the paint change anything? + bne L993B ; brif so + lds TMPSTK ; get back stack pointer +L993B puls a,b,x,u ; get frame from stack + clr CHGFLG ; mark nothing changed + sts TMPSTK ; save stack pointer + leax 1,x ; move start coordinate right + stx HORBEG ; save new coordinate + stu VD1 ; save length of line + sta VD7 ; save up/down flag + beq L98EB ; did we hit the "stop" frame? + bmi L9954 ; brif negative going (up)? + incb ; bump vertical coordinate + cmpb VD6 ; at end? + bls L9958 ; brif not + clrb ; set vertical to 0 (wrap around) +L9954 tstb ; did we wrap? + beq L9934 ; do another block if so + decb ; move up a row +L9958 stb VERBEG+1 ; save vertical coordinate + jsr L99DF ; paint from horizontal to 0 + beq L996E ; brif we hit the border immediately + cmpd #3 ; less than 3 pixels? + blo L9969 ; brif so + leax -2,x ; move two pixels left + bsr L99A1 ; save paint block on the stack +L9969 jsr L99CB ; continue painting to the right +L996C bsr L99BA ; save paint data frame +L996E coma ; complement length of line just painted and add to length of line + comb +L9970 addd VD1 ; save difference between this line and parent line + std VD1 + ble L998C ; brif parent line is shorter + jsr L9506 ; bump horizontal coordinate + jsr L9A12 ; see if we bounced into the border + bne L9983 ; brif not border + ldd #-1 ; move left + bra L9970 ; keep looking +L9983 jsr L9514 ; move horizontally left + bsr L99C6 ; save horizontal coordinate + bsr L99E8 ; paint right + bra L996C ; save paint block and do more +L998C jsr L9506 ; bump horizontal coordinate + leax d,x ; point to right end of parent line + stx HORBEG ; set as curent coordinate + coma ; get amount we extend past parent line + comb + subd #1 + ble L999E ; brif doesn't extend + tfr d,x ; save length of line + bsr L99A1 ; save paint frame +L999E jmp L9934 +L99A1 std VCB ; save number of pixels painted + puls y ; get return address + ldd HORBEG ; get horizontal coordinate + pshs x,b,a ; save horizontal coordinate and pointer + lda VD7 ; get up/down flag + nega ; reverse it +L99AC ldb VERBEG+1 ; get vertical coordainte + pshs b,a ; save vertical coord and up/down flag + pshs y ; put return address back + ldb #2 ; make sure we haven't overflowed memory + jsr LAC33 + ldd VCB ; get line length back + rts +L99BA std VCB ; save length of painted line + puls y ; get return address + ldd HOREND ; get start coord + pshs x,b,a ; save horizontal start and length + lda VD7 ; get up/down flag + bra L99AC ; finish up with the stack +L99C6 ldx HORBEG ; save current horizontal coord and save it + stx HOREND + rts +L99CB std VCD ; save number of pixels painted + ldy HOREND ; get last horizontal start + bsr L99C6 ; save current coordinate + sty HORBEG ; save coordinate + bsr L99E8 ; paint a line + ldx VCD ; get number painted + leax d,x ; add to the number painted going the other way + addd #1 ; now D is length of line + rts +L99DF jsr L99C6 ; put starting coordinate in end + ldy #L9514 ; decrement horizontal coordinate address + bra L99EE ; go paint line +L99E8 ldy #L9506 ; increment horizontal coordinate address + jsr ,y ; bump coordinate +L99EE ldu ZERO ; initialize pixel count + ldx HORBEG ; get starting coordinate +L99F2 bmi L9A0B ; brif out of range for hoizontal coordinate + cmpx VD3 ; at end? + bhi L9A0B ; brif right of max + pshs u,y ; save counter and inc/dec routine pointer + bsr L9A12 ; at border? + beq L9A09 ; brif so + jsr L9377 ; set pixel to paint colour + puls y,u ; restore counter and inc/dec/pointer + leau 1,u ; bump number of painted pixels + jsr ,y ; inc/dec screen address + bra L99F2 ; go do another pixel +L9A09 puls y,u ; get back counter and inc/dec routine +L9A0B tfr u,d ; save count in D + tfr d,x ; and in X + subd ZERO ; set flags on D (smaller/faster than cmpd ZERO) + rts +L9A12 jsr [VD9] ; get the screen address + tfr a,b ; save pixel mask + andb VD8 ; set pixel to border colour + pshs b,a ; save mask and border + anda ,x ; mask current pixel into A + cmpa 1,s ; does it match border? Z=1 if so + puls a,b,pc ; restore mask, border pixel, and return +; PLAY command +; This is here mixed in with the graphics package because it shares some machinery with DRAW. +PLAY ldx ZERO ; default values for note length, etc. + ldb #1 + pshs x,b ; save default values + jsr LB156 ; evaluate argument + clrb ; enable DA and sound output + jsr LA9A2 + jsr LA976 +L9A32 jsr LB654 ; fetch PLAY string details + bra L9A39 ; go evaluate the string +L9A37 puls b,x ; get back play string details +L9A39 stb VD8 ; save length of string + beq L9A37 ; brif end of string + stx VD9 ; save start of string + lbeq LA974 ; brif NULL string - disable sound and return +L9A43 tst VD8 ; have anything left? + beq L9A37 ; brif not + jsr L9B98 ; get command character + cmpa #'; ; command separator? + beq L9A43 ; brif so - ignore it + cmpa #'' ; '? + beq L9A43 ; brif so - ignore it + cmpa #'X ; execuate sub string? + lbeq L9C0A ; brif so - handle it + bsr L9A5C ; handle other commands + bra L9A43 ; look for more stuff +L9A5C cmpa #'O ; octave? + bne L9A6D ; brif not + ldb OCTAVE ; get current octave + incb ; 1-base it + bsr L9AC0 ; get value if present + decb ; zero-base it + cmpb #4 ; valid octave? + bhi L9ACD ; raise error if not + stb OCTAVE ; save new octave + rts +L9A6D cmpa #'V ; volume? + bne L9A8B ; brif not + ldb VOLHI ; get current high volume limit + lsrb ; shift 2 bits right (DA is 6 bits in high bits) + lsrb + subb #31 ; subtract out mid value offset + bsr L9AC0 ; read argument + cmpb #31 ; maximum range is 31 + bhi L9ACD ; brif out of range + aslb ; adjust back in range + aslb + pshs b ; save new volume + ldd #0x7e7e ; midrange value for both high and low + adda ,s ; add new volume to high limit + subb ,s+ ; subtract volume from low limit + std VOLHI ; save new volume limits (sets high and low amplitudes) + rts +L9A8B cmpa #'L ; note length? + bne L9AB2 ; brif not + ldb NOTELN ; get current length + bsr L9AC0 ; read parameter + tstb ; resulting length 0? + beq L9ACD ; brif so - problem + stb NOTELN ; save new length + clr DOTVAL ; reset note timer scale factor +L9A9A bsr L9A9F ; check for dot + bcc L9A9A ; brif there was one + rts +L9A9F tst VD8 ; check length + beq L9AAD ; brif zero + jsr L9B98 ; get command character + cmpa #'. ; dot? + beq L9AAF ; brif so + jsr L9BE2 ; move input back and bump length +L9AAD coma ; set C to indicate nothing found + rts +L9AAF inc DOTVAL ; bump number of dots + rts +L9AB2 cmpa #'T ; tempo? + bne L9AC3 ; brif not + ldb TEMPO ; get current tempo + bsr L9AC0 ; parse tempo argument + tstb ; 0? + beq L9ACD ; brif so - invalid + stb TEMPO ; save new tempo + rts +L9AC0 jmp L9BAC ; evaluate various operators +L9AC3 cmpa #'P ; pause? + bne L9AEB ; brif not + jsr L9CCB ; evaluate parameter + tstb ; is the pause number 0? + bne L9AD0 ; brif not +L9ACD jmp LB44A ; raise FC error +L9AD0 lda DOTVAL ; save current volume and note scale + ldx VOLHI + pshs x,a + lda #0x7e ; drop DA to mid range + sta VOLHI + sta VOLLOW + clr DOTVAL + bsr L9AE7 ; go play a "silence" + puls a,x ; restore volume and note scale + sta DOTVAL + stx VOLHI + rts +L9AE7 clr ,-s ; set not number 0 + bra L9B2B ; go play it +L9AEB cmpa #'N ; N for "note"? + bne L9AF2 ; brif not - it's optional + jsr L9B98 ; skip the "N" +L9AF2 cmpa #'A ; is it a valid note? + blo L9AFA ; brif not + cmpa #'G ; is it above the note range? + bls L9AFF ; brif not - valid note +L9AFA jsr L9BBE ; evaluate a number + bra L9B22 ; process note value +L9AFF suba #'A ; normalize note number to 0 + ldx #L9C5B ; point to note number lookup table + ldb a,x ; get not number + tst VD8 ; any command characters left? + beq L9B22 ; brif not + jsr L9B98 ; get character + cmpa #'# ; sharp? + beq L9B15 ; brif so + cmpa #'+ ; also sharp? + bne L9B18 ; brif not +L9B15 incb ; add one half tone + bra L9B22 +L9B18 cmpa #'- ; flat? + bne L9B1F ; brif not + decb ; subtract one half tone + bra L9B22 +L9B1F jsr L9BE2 ; back up command pointer +L9B22 decb ; adjust note number (zero base it) + cmpb #11 ; is it valid? + bhi L9ACD ; raise error if not + pshs b ; save note value + ldb NOTELN ; get note length +L9B2B lda TEMPO ; get tempo value + mul ; calculate note duration + std VD5 ; save duration + leau 1,s ; point to where the stack goes after we're done + lda OCTAVE ; get current octave + cmpa #1 ; 0 or 1? + bhi L9B64 ; brif not + ldx #L9C62 ; point to delay table + ldb #2*12 ; 24 bytes per octave + mul ; now we have the base address + abx ; now X points to the octave base + puls b ; get back note value + aslb ; two bytes per delay + abx ; now we're pointing to the delay + leay ,x ; save pointer to note value + bsr L9B8C ; calculate note timer value + std PLYTMR ; set timer for note playing (IRQ will count this down) +L9B49 bsr L9B57 ; set to mid range and delay + lda VOLHI ; get high value + bsr L9B5A ; set to high value and delay + bsr L9B57 ; set to mid range and delay + lda VOLLOW ; get low value + bsr L9B5A ; set to low value and delay + bra L9B49 ; do it again (IRQ will break the loop) +L9B57 lda #0x7e ; mid value for DA with RS232 marking + nop ; a delay to fine tune frequencies +L9B5A sta PIA1 ; set DA + ldx ,y ; get delay value +L9B5F leax -1,x ; count down + bne L9B5F ; brif not done yet + rts +L9B64 ldx #L9C92-2*12 ; point to delay table for octaves 2+ + ldb #12 ; 12 bytes per octave + mul ; now we have the offset to the desired octave + abx ; now we point to the start of the octave + puls b ; get back note value + abx ; now we point to the delay value + bsr L9B8C ; calculate timer value + std PLYTMR ; set play timer (IRQ counts this down) +L9B72 bsr L9B80 ; send mid value and delay + lda VOLHI ; get high value + bsr L9B83 ; send high value and delay + bsr L9B80 ; send low value and delay + lda VOLLOW ; get low value + bsr L9B83 ; send low value and delay + bra L9B72 ; do it again (IRQ will break the loop) +L9B80 lda #0x7e ; mid range value with RS232 marking + nop ; fine tuning delay +L9B83 sta PIA1 ; set DA + lda ,x ; get delay value +L9B88 deca ; count down + bne L9B88 ; brif not done + rts +L9B8C ldb #0xff ; base timer value + lda DOTVAL ; get number of dots + beq L9B97 ; use default value if 0 + adda #2 ; add in constant timer factor + mul ; multiply scale by base + lsra ; divide by two - each increment will increase note timer by 128 + rorb +L9B97 rts +L9B98 pshs x ; save register +L9B9A tst VD8 ; do we have anything left? + beq L9BEB ; brif not - raise error + ldx VD9 ; get parsing address + lda ,x+ ; get character + stx VD9 ; save pointer + dec VD8 ; account for character consumed + cmpa #0x20 ; space? + beq L9B9A ; brif so - skip it + puls x,pc ; restore register and return +L9BAC bsr L9B98 ; get character + cmpa #'+ ; add one? + beq L9BEE ; brif so + cmpa #'- ; subtract one? + beq L9BF2 ; brif so + cmpa #'> ; double? + beq L9BFC ; brif so + cmpa #'< ; halve? + beq L9BF7 ; brif so +L9BBE cmpa #'= ; variable equate? + beq L9C01 ; brif so + jsr L90AA ; clear carry if numeric + bcs L9BEB ; brif not numeric + clrb ; initialize value to 0 +L9BC8 suba #'0 ; remove ASCII bias + sta VD7 ; save digit + lda #10 ; make room for digit + mul + tsta ; did we overflow 8 bits? + bne L9BEB ; brif so + addb VD7 ; add in digit + bcs L9BEB ; brif that overflowed + tst VD8 ; more digits? + beq L9BF1 ; brif not + jsr L9B98 ; get character + jsr L90AA ; clear carry if numeric + bcc L9BC8 ; brif another digit +L9BE2 inc VD8 ; unaccount for character just read + ldx VD9 ; move pointer back + leax -1,x + stx VD9 + rts +L9BEB jmp LB44A ; raise FC error +L9BEE incb ; bump param + beq L9BEB ; brif overflow +L9BF1 rts +L9BF2 tstb ; already zero? + beq L9BEB ; brif so - underflow + decb ; decrease parameter + rts +L9BF7 tstb ; already at 0? + beq L9BEB ; brif so - raise error + lsrb ; halve it + rts +L9BFC tstb ; will it overflow? + bmi L9BEB ; brif so + aslb ; double it + rts +L9C01 pshs u,y ; save registers + bsr L9C1B ; interpret command string as a variable + jsr LB70E ; convert it to an 8 bit number + puls y,u,pc ; restore registers and return +L9C0A jsr L9C1B ; evaluate expression in command string + ldb #2 ; room for 4 bytes? + jsr LAC33 + ldb VD8 ; get the command length and pointer + ldx VD9 + pshs x,b ; save them + jmp L9A32 ; go process the sub string +L9C1B ldx VD9 ; get command pointer + pshs x ; save it + jsr L9B98 ; get input character + jsr LB3A2 ; set carry if not alpha + bcs L9BEB ; brif not a variable reference +L9C27 jsr L9B98 ; get command character + cmpa #'; ; semicolon? + bne L9C27 ; keep scanning if not + puls x ; get back start of variable string + ldu CHARAD ; get current interpreter input pointer + pshs u ; save it + stx CHARAD ; point interpreter at command string + jsr LB284 ; evaluate expression as string + puls x ; restore interpeter input pointer + stx CHARAD + rts +; The bit of Extended Basic's IRQ routine that handles PLAY. Note that everything after +; clr PLYTMR+1 could be replaced with a simple lds 8,s followed by rts. +L9C3E clra ; make sure DP is set to 0 + tfr a,dp + ldd PLYTMR ; is PLAY running? + lbeq LA9BB ; brif not - transfer control on the Color Basic's routine + subd VD5 ; subtract out the interval + std PLYTMR ; save new timer value + bhi L9C5A ; brif it isn't <= 0 + clr PLYTMR ; disable the timer + clr PLYTMR+1 + puls a ; get saved CC + lds 7,s ; set stack to saved U value + anda #0x7f ; clear E flag (to return minimal state) + pshs a ; set fake "FIRQ" stack frame +L9C5A rti +L9C5B fcb 10,12,1,3,5,6,8 ; table of half tone numbers for notes A-G +L9C62 fdb 0x01a8,0x0190,0x017a,0x0164 ; delays for octave 1 + fdb 0x0150,0x013d,0x012b,0x011a + fdb 0x010a,0x00fb,0x00ed,0x00df + fdb 0x00d3,0x00c7,0x00bb,0x00b1 ; delays for octave 2 + fdb 0x00a6,0x009d,0x0094,0x008b + fdb 0x0083,0x007c,0x0075,0x006e +L9C92 fcb 0xa6,0x9c,0x93,0x8b ; delays for octave 3 + fcb 0x83,0x7b,0x74,0x6d + fcb 0x67,0x61,0x5b,0x56 + fcb 0x51,0x4c,0x47,0x43 ; delays for octave 4 + fcb 0x3f,0x3b,0x37,0x34 + fcb 0x31,0x2e,0x2b,0x28 + fcb 0x26,0x23,0x21,0x1f ; delays for octave 5 + fcb 0x1d,0x1b,0x19,0x18 + fcb 0x16,0x14,0x13,0x12 +; DRAW command +DRAW ldx ZERO ; create an empty "DRAW" frame + ldb #1 + pshs x,b + stb SETFLG ; set to "PSET" mode + stx VD5 ; clear update and draw flag + jsr L959A ; set active colour byte + jsr LB156 ; evaluate command string +L9CC6 jsr LB654 ; fetch command string details + bra L9CD3 ; interpret the command string +L9CCB jsr L9B98 ; fetch command character + jmp L9BBE ; evaluate a number +L9CD1 puls b,x ; get previously saved command string +L9CD3 stb VD8 ; save length counter + beq L9CD1 ; brif end of string + stx VD9 ; save pointer + lbeq L9DC7 ; brif overall end of command +L9CDD tst VD8 ; are we at the end of the string? + beq L9CD1 ; brif so - return to previous string + jsr L9B98 ; get command character + cmpa #'; ; semicolon? + beq L9CDD ; brif so - ignore it + cmpa #'' ; '? + beq L9CDD ; brif so - ignore that too + cmpa #'N ; update position toggle? + bne L9CF4 ; brif not + com VD5 ; toggle update position flag + bra L9CDD ; get on for another command +L9CF4 cmpa #'B ; blank flag? + bne L9CFC ; brif not + com VD6 ; toggle blank flag + bra L9CDD ; get on for another command +L9CFC cmpa #'X ; substring? + lbeq L9D98 ; brif so - execute command + cmpa #'M ; move draw position? + lbeq L9E32 ; brif so + pshs a ; save command character + ldb #1 ; default value if no number follows + tst VD8 ; is there something there? + beq L9D21 ; brif not + jsr L9B98 ; get character + jsr LB3A2 ; set C if not alpha + pshs cc ; save alpha state + jsr L9BE2 ; move back pointer + puls cc ; get back alpha flag + bcc L9D21 ; brif it's alpha + bsr L9CCB ; evaluate a number +L9D21 puls a ; get command back + cmpa #'C ; color change? + beq L9D4F ; brif so + cmpa #'A ; angle? + beq L9D59 ; brif so + cmpa #'S ; scale? + beq L9D61 ; brif so + cmpa #'U ; up? + beq L9D8F ; brif so + cmpa #'D ; down? + beq L9D8C ; brif so + cmpa #'L ; left? + beq L9D87 ; brif so + cmpa #'R ; right? + beq L9D82 ; brif so + suba #'E ; normalize the half cardinals to 0 + beq L9D72 ; brif E (45°) + deca ; F (135°?) + beq L9D6D ; brif so + deca ; G (225°?) + beq L9D7B ; brif so + deca ; H (315°?) + beq L9D69 ; brif so +L9D4C jmp LB44A ; raise FC error +L9D4F jsr L955D ; adjust colour for PMODE + stb FORCOL ; save new foreground colour + jsr L959A ; set up working colour and all pixels byte +L9D57 bra L9CDD ; go process another command +L9D59 cmpb #4 ; only 3 angles are valid + bhs L9D4C ; brif not valid + stb ANGLE ; save new angle + bra L9D57 ; go process another command +L9D61 cmpb #63 ; only 64 scale values are possible + bhs L9D4C ; brif out of range + stb SCALE ; save new scale factor + bra L9D57 ; go process another command +L9D69 clra ; make horizontal negative + bsr L9DC4 + skip1 +L9D6D clra ; keep horizontal distance positive + tfr d,x ; make horizontal distance and vertical distance the same + bra L9DCB ; go do the draw thing +L9D72 clra ; zero extend horizontal distance + tfr d,x ; set it as vertical + bsr L9DC4 ; negate horizontal distance + exg d,x ; swap directions (vertical is now negative) + bra L9DCB ; go do the draw thing +L9D7B clra ; zero extend horizontal distance + tfr d,x ; copy horizontal to vertical + bsr L9DC4 ; negate horizontal + bra L9DCB ; go do the drawing thing +L9D82 clra ; zero extend horizontal distance +L9DB3 ldx ZERO ; no vertical distance + bra L9DCB ; go do the drawing things +L9D87 clra ; zero extend horizontal + bsr L9DC4 ; negate horizontal + bra L9DB3 ; zero out vertical and do the drawing thing +L9D8C clra ; zero extend distance + bra L9D92 ; make the distance vertical and zero out horizontal +L9D8F clra ; zero extend distance + bsr L9DC4 ; negate distance +L9D92 ldx ZERO ; zero out vertical distance + exg x,d ; swap vertical and horizontal + bra L9DCB ; go do the drawing thing +L9D98 jsr L9C1B ; evaluate substring expression + ldb #2 ; is there enough room for the state? + jsr LAC33 + ldb VD8 ; save current command string state + ldx VD9 + pshs x,b + jmp L9CC6 ; go evaluate the sub string +L9DA9 ldb SCALE ; get scale factor + beq L9DC8 ; brif zero - default to full size + clra ; zero extend + exg d,x ; put distance somewhere useful + sta ,-s ; save MS of distance + bpl L9DB6 ; brif positive distance + bsr L9DC3 ; negate the distance +L9DB6 jsr L9FB5 ; multiply D and X + tfr u,d ; save ms bytes in D + lsra ; divide by 2 + rorb +L9DBD lsra ; ...divide by 4 + rorb + tst ,s+ ; negative distance? + bpl L9DC7 ; brif it was positive +L9DC3 nega ; negate D +L9DC4 negb + sbca #0 +L9DC7 rts +L9DC8 tfr x,d ; copy unchanged sitance to D + rts +L9DCB pshs b,a ; save horizontal distance + bsr L9DA9 ; apply scale factor to vertical + puls x ; get horizontal distance + pshs b,a ; save scaled vertical + bsr L9DA9 ; apply scale to horizontal + puls x ; get back vertical distance + ldy ANGLE ; get draw angle and scale + pshs y ; save them +L9DDC tst ,s ; is there an angle? + beq L9DE8 ; brif no angle + exg x,d ; swap distances + bsr L9DC3 ; negate D + dec ,s ; account for one tick around the rotation + bra L9DDC ; see if we're there yet +L9DE8 puls y ; get angle and scale back + ldu ZERO ; default end position (horizontal) is 0 + addd HORDEF ; add default horizontal to horizontal distance + bmi L9DF2 ; brif we went negative + tfr d,u ; save calculated end coordindate +L9DF2 tfr x,d ; get vertical distance somewhere useful + ldx ZERO ; default vertical end is 0 + addd VERDEF ; add distance to default vertical start + bmi L9DFC ; brif negative - use 0 + tfr d,x ; save calculated end coordinate +L9DFC cmpu #256 ; is horizontal in range? + blo L9E05 ; brif su + ldu #255 ; maximize it +L9E05 cmpx #192 ; is vertical in range? + blo L9E0D ; brif so + ldx #191 ; maximize it +L9E0D ldd HORDEF ; set starting coordinates for the line + std HORBEG + ldd VERDEF + std VERBEG + stx VEREND ; set end coordinates + stu HOREND + tst VD5 ; are we updating position? + bne L9E21 ; brif not + stx VERDEF ; update default coordinates + stu HORDEF +L9E21 jsr L9420 ; normalize coordindates + tst VD6 ; are we drawing something? + bne L9E2B ; brif not + jsr L94A1 ; draw the line +L9E2B clr VD5 ; reset draw and update flags + clr VD6 + jmp L9CDD ; do another command +L9E32 jsr L9B98 ; get a command character + pshs a ; save it + jsr L9E5E ; evaluate horizontal distance + pshs b,a ; save it + jsr L9B98 ; get character + cmpa #', ; comma between coordinates? + lbne L9D4C ; brif not - raise error + jsr L9E5B ; evaluate vertical distance + tfr d,x ; save vertical distance + puls u ; get horizontal distance + puls a ; get back first command character + cmpa #'+ ; was it + at start? + beq L9E56 ; brif +; treat values as positive + cmpa #'- ; was it -? + bne L9DFC ; brif not - treat it as absolute +L9E56 tfr u,d ; put horizontal distance somewhere useful + jmp L9DCB ; move draw position (relative) +L9E5B jsr L9B98 ; get input character +L9E5E cmpa #'+ ; leading +? + beq L9E69 ; brif so + cmpa #'- ; leading -? + beq L9E6A ; brif so - negative + jsr L9BE2 ; move pointer back one +L9E69 clra ; 0 for +, nonzero for - +L9E6A pshs a ; save sign flag + jsr L9CCB ; evaluate number + puls a ; get sign flag + tsta ; negative? + beq L9E78 ; brif not + clra ; zero extend and negate + negb + sbca #0 +L9E78 rts +; Table of sines and cosines for CIRCLE +L9E79 fdb 0x0000,0x0001 ; subarc 0 + fdb 0xfec5,0x1919 ; subarc 1 + fdb 0xfb16,0x31f2 ; subarc 2 + fdb 0xf4fb,0x4a51 ; subarc 3 + fdb 0xec84,0x61f9 ; subarc 4 + fdb 0xe1c7,0x78ae ; subarc 5 + fdb 0xd4dc,0x8e3b ; subarc 6 + fdb 0xc5e5,0xa269 ; subarc 7 + fdb 0xb506,0xb506 ; subarc 8 +; CIRCLE command +; The circle is drawn as a 64 sided polygon (64 LINE commands essentially) +CIRCLE cmpa #'@ ; is there an @ before coordinates? + bne L9EA3 ; brif not + jsr GETNCH ; eat the @ +L9EA3 jsr L9522 ; get max coordinates for screen + jsr L93B2 ; parse coordinates for circle centre + jsr L931D ; normalize the start coordinates + ldx ,u ; get horizontal coordinate + stx VCB ; save it + ldx 2,u ; get vertical coordinate + stx VCD ; saveit + jsr SYNCOMMA ; make sure we have a comma + jsr LB73D ; evaluate radius expression + ldu #VCF ; point to temp storage + stx ,u ; save radius + jsr L9320 ; normalize radius + lda #1 ; default to PSET + sta SETFLG + jsr L9581 ; evaluate the colour expression + ldx #0x100 ; height/width default value + jsr GETCCH ; is there a ratio? + beq L9EDF ; brif not + jsr SYNCOMMA ; make sure we have a comma + jsr LB141 ; evaluate the ratio + lda FP0EXP ; multiply ratio by 256 + adda #8 + sta FP0EXP + jsr LB740 ; evaluate ratio to X (fraction part in LSB) +L9EDF lda PMODE ; get graphics mode + bita #2 ; is it even? + beq L9EE9 ; brif so + tfr x,d ; double the ratio + leax d,x +L9EE9 stx VD1 ; save height/width ratio + ldb #1 ; set the SET flag to PSET + stb SETFLG + stb VD8 ; set first time flag (set to 0 after arc drawn) + jsr L9FE2 ; evaluate circle starting point (octant, subarc) + pshs b,a ; save startpoint + jsr L9FE2 ; evaluate circle end point (octant, subarc) + std VD9 ; save endp oint + puls a,b +L9EFD pshs b,a ; save current circle position + ldx HOREND ; move end coordinates to start coordinates + stx HORBEG + ldx VEREND + stx VERBEG + ldu #L9E79+2 ; point to sine/cosine table + anda #1 ; even octant? + beq L9F11 ; brif so + negb ; convert 0-7 to 8-1 for odd octants + addb #8 +L9F11 aslb ; four bytes per table entry + aslb + leau b,u ; point to correct table entry + pshs u ; save sine/cosine table entry pointer + jsr L9FA7 ; calculate horizontal offset + puls u ; get back table entry pointer + leau -2,u ; move to cosine entry + pshs x ; save horizontal offset + jsr L9FA7 ; calculate vertical offset + puls y ; put horizontal in Y + lda ,s ; get octant number + anda #3 ; is it 0 or 4? + beq L9F31 ; brif so + cmpa #3 ; is it 3 or 7? + beq L9F31 ; brif so + exg x,y ; swap horizontal and vertical +L9F31 stx HOREND ; save horizontal offset + tfr y,x ; put vertical offset in X + ldd VD1 ; get height/width ratio + jsr L9FB5 ; multiply vertical by h/w ratio + tfr y,d ; save the product to D + tsta ; did it overflow? + lbne LB44A ; brif so + stb VEREND ; save vertical coordinate MSB + tfr u,d ; get LSW of product + sta VEREND+1 ; save LSB of integer part (we have 8 bits of fraction in the ratio) + lda ,s ; get octant + cmpa #2 ; is it 0 or 1? + blo L9F5B ; brif so + cmpa #6 ; is it 6 or 7? + bhs L9F5B ; brif so + ldd VCB ; get horizontal centre + subd HOREND ; subtract horizontal displacement + bcc L9F68 ; brif we didn't overflow the screen + clra ; zero out coordinate if we overflowed the screen + clrb + bra L9F68 +L9F5B ldd VCB ; get horizontal coordinate of the centre + addd HOREND ; add displacement + bcs L9F66 ; brif overlod + cmpd VD3 ; larger than max horizontal coord? + blo L9F68 ; brif not +L9F66 ldd VD3 ; maximize the coordinate +L9F68 std HOREND ; save horizontal ending coordainte + lda ,s ; get octant + cmpa #4 ; is it 0-3? + blo L9F7A ; brif so + ldd VCD ; get vertical coordinate of centre + subd VEREND ; subtract displacement + bcc L9F87 ; brif we didn't overflow the screen + clra ; minimize to top of screen + clrb + bra L9F87 +L9F7A ldd VCD ; get vertical centre coordinate + addd VEREND ; add displacement + bcs L9F85 ; brif we overflowed the screen + cmpd VD5 ; did we go past max coordinate? + blo L9F87 ; brif not +L9F85 ldd VD5 ; maximize the coordinate +L9F87 std VEREND ; save end coordinate + tst VD8 ; check first time flag + bne L9F8F ; do not draw if first time through (it was setting start coord) + bsr L9FDF ; draw the line +L9F8F puls a,b ; get arc number and sub arc + lsr VD8 ; get first time flag value (and clear it!) + bcs L9F9A ; do not check for end point after drawing for first coordinate + cmpd VD9 ; at end point? + beq L9FA6 ; brif drawing finished +L9F9A incb ; bump arc counter + cmpb #8 ; done 8 arcs? + bne L9FA3 ; brif not + inca ; bump octant + clrb ; reset subarc number + anda #7 ; make sure octant number stays in 0-7 range +L9FA3 jmp L9EFD ; go do another arc +L9FA6 rts +L9FA7 ldx VCF ; get radius + ldd ,u ; get sine/cosine table entry + beq L9FB4 ; brif 0 - offset = radius + subd #1 ; adjust values to correct range + bsr L9FB5 ; multiply radius by sine/cosine + tfr y,x ; resturn result in X +L9FB4 rts +L9FB5 pshs u,y,x,b,a ; save registers and reserve temp space + clr 4,s ; reset overflow byte (YH) + lda 3,s ; calcuate B*XL + mul + std 6,s ; put in "U" + ldd 1,s ; calculate B*XH + mul + addb 6,s ; accumluate with previous product + adca #0 + std 5,s ; save in YL,UH + ldb ,s ; calculate A*XL + lda 3,s + mul + addd 5,s ; accumulate with previous partical product + std 5,s ; save in YL,UH + bcc L9FD4 ; brif no carry + inc 4,s ; bump YH for carry +L9FD4 lda ,s ; calculate A*XH + ldb 2,s + mul + addd 4,s ; accumulate with previous partial product + std 4,s ; save in Y (we can't have a carry here) + puls a,b,x,y,u,pc ; restore multiplicands and return results +L9FDF jmp L94A1 ; go draw a line +L9FE2 clrb ; default arc number (0) + jsr GETCCH ; is there something there for a value? + beq L9FF8 ; brif not + jsr SYNCOMMA ; evaluate , + expression + jsr LB141 + lda FP0EXP ; multiply by 64 + adda #6 + sta FP0EXP + jsr LB70E ; get integer value of circle fraction + andb #0x3f ; max value of 63 +L9FF8 tfr b,a ; save arc value in A to calculate octant + andb #7 ; calculate subarc + lsra ; calculate octant + lsra + lsra + rts
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/secb.s Sat Dec 08 19:57:01 2018 -0700 @@ -0,0 +1,11797 @@ + *pragma nolist + include defs.s +DC0DC equ 0xC0DC ; needed for Disk Basic path jump backs + *pragma list +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; EXTENDED COLOR BASIC ROM area +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + org EXBAS + fcc 'EX' ; magic number that Color Basic uses to identify the presence of Extended Basic +L8002 ldx #L80DE ; point to command interpretation table information + ldu #COMVEC+10 ; point to command interpretation table location + ldb #10 ; 10 bytes to move + jsr LA59A ; copy command interpretation table + ldx #LB277 ; initialize Disk Basic's entries to error + stx 3,u + stx 8,u + ldx #XIRQSV ; set up IRQ service routine + stx IRQVEC+1 + ldx ZERO ; reset the TIMER value + stx TIMVAL + jsr XVEC18 ; do a bunch of initialization + ldd #0x2c05 ; initialize DLOAD baud rate constant and timeout + std DLBAUD + ldx #USR0 ; set up pointer to USR routine addresses + stx USRADR + ldu #LB44A ; set up USR routine addresses to "FC error" + ldb #10 ; there are 10 routines +L8031 stu ,x++ ; set a routine to FC error + decb ; done all? + bne L8031 ; brif not + lda #0x7e ; op code of JMP extended (for RAM hook intialization) + sta RVEC20 ; command interpretation loop + ldx #XVEC20 + stx RVEC20+1 + sta RVEC15 ; expression evaluation + ldx #XVEC15 + stx RVEC15+1 + sta RVEC19 ; number parsing + ldx #XVEC19 + stx RVEC19+1 + sta RVEC9 ; PRINT + ldx #XVEC9 + stx RVEC9+1 + sta RVEC17 ; error handler + ldx #XVEC17 + stx RVEC17+1 + sta RVEC4 ; generic input + ldx #XVEC4 + stx RVEC4+1 + sta RVEC3 ; generic output + ldx #XVEC3 + stx RVEC3+1 + sta RVEC8 ; close file + ldx #XVEC8 + stx RVEC8+1 + sta RVEC23 ; tokenize line + ldx #XVEC23 + stx RVEC23+1 + sta RVEC18 ; RUN + ldx #XVEC18 + stx RVEC18+1 + sta EXPJMP ; exponentiation + ldx #L8489 + stx EXPJMP+1 + jsr L96E6 ; initialize graphics stuff + lda PIA0+3 ; enable 60Hz interrupt + ora #1 + sta PIA0+3 + ldx #'D*256+'K ; magic number for a Disk Basic ROM + cmpx DOSBAS ; do we have a Disk Basic ROM? + lbeq DOSBAS+2 ; brif so - launch it + andcc #0xaf ; enable interrupts +L80B2 ldx #L80E8-1 ; show sign on message + jsr STRINOUT +L80B8 ldx #XBWMST ; install warm start handler + stx RSTVEC + jmp LA0E2 ; set up warm start flag and launch immediate mode +; Extended Basic warm start code +XBWMST fcb 0xff ; mark routine as invalid so that ROMs are always copied to RAM on RESET + clr PLYTMR ; cancel any PLAY command in progress + clr PLYTMR+1 + lda PIA0+3 ; enable 60Hz interrupt + ora #1 + sta PIA0+3 + jmp BAWMST ; let Color Basic's warm start process run +; This code is to fix the famous PCLEAR bug. It replaces dead code in the 1.0 ROM. This patch corrects +; the input pointer so that it points to the correct place after the program has been relocated by +; PCLEAR instead of continuing with something that, in the best case, is a syntax error. +L80D0 lda CURLIN ; immediate mode? + inca + beq L80DD ; brif so + tfr y,d ; save offset to D + subd TXTTAB ; see how far into the program we are + addd CHARAD ; now adjust the input pointer based on that + std CHARAD ; save corrected input pointer +L80DD rts +L80DE fcb 25 ; 25 Extended Basic commands + fdb L8183 ; reserved word table (commands) + fdb L813C ; interpretation handler (commands) + fcb 14 ; 14 Extended Basic functions + fdb L821E ; reserved word table (functions) + fdb L8168 ; function handler +L80E8 fcc 'EXTENDED COLOR BASIC 2.0' + fcb 0x0d + fcc 'COPR. 1982, 1986 BY TANDY ' + fcb 0x0d + fcc 'UNDER LICENSE FROM MICROSOFT' + fcb 0x0d,0x0d,0x00 +; Extended Basic command interpretation loop +L813C cmpa #0xcb ; is it an Extended Basic command? + bhi L8148 ; brif not + ldx #L81F0 ; point to dispatch table + suba #0xb5 ; normalize the token number so 0 is the first entry + jmp LADD4 ; go transfer control to the command +L8148 cmpa #0xff ; is it a function token? + beq L8154 ; brif so - for MID$()=, TIMER= + cmpa #0xcd ; is it a token for a keyword that isn't a command? + bls L8165 ; brif so - error for USING and FN +L8150 jmp [COMVEC+23] ; transfer control to Disk Basic if it is present +L8154 jsr GETNCH ; get token after the function flag + cmpa #0x90 ; MID$? + lbeq L86D6 ; brif so (substring replacement) + cmpa #0x9f ; TIMER? + lbeq L8960 ; brif so - TIMER setting + jsr RVEC22 ; do a RAM hook in case something wants to extend this +L8165 jmp LB277 ; we have nothing valid here +; Function handler +L8168 cmpb #2*33 ; is it a valid Extended Basic function? + bls L8170 ; brif so +L816C jmp [COMVEC+28] ; transfer control to Disk Basic if it is present +L8170 subb #2*20 ; normalize Extended Basic functions to 0 + cmpb #2*8 ; Above HEX$? + bhi L817D ; brif so - we don't pre-evaluate an argument + pshs b ; save token value + jsr LB262 ; evaluate the function parameter + puls b ; get back token value +L817D ldx #L8257 ; point to dispatch table + jmp LB2CE ; go transfer control to the function +; Reserved words (commands) +L8183 fcs 'DEL' ; 0xb5 + fcs 'EDIT' ; 0xb6 + fcs 'TRON' ; 0xb7 + fcs 'TROFF' ; 0xb8 + fcs 'DEF' ; 0xb9 + fcs 'LET' ; 0xba + fcs 'LINE' ; 0xbb + fcs 'PCLS' ; 0xbc + fcs 'PSET' ; 0xbd + fcs 'PRESET' ; 0xbe + fcs 'SCREEN' ; 0xbf + fcs 'PCLEAR' ; 0xc0 + fcs 'COLOR' ; 0xc1 + fcs 'CIRCLE' ; 0xc2 + fcs 'PAINT' ; 0xc3 + fcs 'GET' ; 0xc4 + fcs 'PUT' ; 0xc5 + fcs 'DRAW' ; 0xc6 + fcs 'PCOPY' ; 0xc7 + fcs 'PMODE' ; 0xc8 + fcs 'PLAY' ; 0xc9 + fcs 'DLOAD' ; 0xca + fcs 'RENUM' ; 0xcb + fcs 'FN' ; 0xcc + fcs 'USING' ; 0xcd +; Dispatch table (commands) +L81F0 fdb DEL ; 0xb5 DEL + fdb EDIT ; 0xb6 EDIT + fdb TRON ; 0xb7 TRON + fdb TROFF ; 0xb8 TROFF + fdb DEF ; 0xb9 DEF + fdb LET ; 0xba LET (note: implemented by Color Basic!) + fdb LINE ; 0xbb LINE + fdb PCLS ; 0xbc PCLS + fdb PSET ; 0xbd PSET + fdb PRESET ; 0xbe PRESET + fdb SCREEN ; 0xbf SCREEN + fdb PCLEAR ; 0xc0 PCLEAR + fdb COLOR ; 0xc1 COLOR + fdb CIRCLE ; 0xc2 CIRCLE + fdb PAINT ; 0xc3 PAINT + fdb GET ; 0xc4 GET + fdb PUT ; 0xc5 PUT + fdb DRAW ; 0xc6 DRAW + fdb PCOPY ; 0xc7 PCOPY + fdb PMODETOK ; 0xc8 PMODE + fdb PLAY ; 0xc9 PLAY + fdb DLOAD ; 0xca DLOAD + fdb RENUM ; 0xcb RENUM +; Reserved words (functions) +L821E fcs 'ATN' ; 0x94 + fcs 'COS' ; 0x95 + fcs 'TAN' ; 0x96 + fcs 'EXP' ; 0x97 + fcs 'FIX' ; 0x98 + fcs 'LOG' ; 0x99 + fcs 'POS' ; 0x9a + fcs 'SQR' ; 0x9b + fcs 'HEX$' ; 0x9c + fcs 'VARPTR' ; 0x9d + fcs 'INSTR' ; 0x9e + fcs 'TIMER' ; 0x9f + fcs 'PPOINT' ; 0xa0 + fcs 'STRING$' ; 0xa1 +; Dispatch table (functions) +L8257 fdb ATN ; 0x94 ATN + fdb COS ; 0x95 COS + fdb TAN ; 0x96 TAN + fdb EXP ; 0x97 EXP + fdb FIX ; 0x98 FIX + fdb LOG ; 0x99 LOG + fdb POS ; 0x9a POS + fdb SQR ; 0x9b SQR + fdb HEXDOL ; 0x9c HEX$ + fdb VARPTRTOK ; 0x9d VARPTR + fdb INSTR ; 0x9e INSTR + fdb TIMER ; 0x9f TIMER + fdb PPOINT ; 0xa0 PPOINT + fdb STRING ; 0xa1 STRING$ +; Generic output handler +XVEC3 tst DEVNUM ; screen? + lbeq L95AC ; brif so - force text screen active + pshs b ; save register + ldb DEVNUM ; get output device + cmpb #-3 ; check for DLOAD + puls b ; restore register + bne L8285 ; brif not DLOAD + leas 2,s ; bail out of output handler if DLOAD +L8285 rts +; Close file handler. This corrects a bug in Color Basic 1.0 which didn't handle writing the +; end of file block correctly. That bug is fixed in Color Basic 1.1 so this isn't required +; if a recent enough version of Color Basic is installed. +XVEC8 lda DEVNUM ; get device number + inca ; is it tape? + bne L8285 ; brif not - we aren't going to mess with it + lda FILSTA ; get tape file status + cmpa #2 ; output file? + bne L8285 ; brif not + lda CINCTR ; is there anything waiting to be written out? + bne L8285 ; brif so - mainline code will handle it properly + clr DEVNUM ; reset output to screen + leas 2,s ; don't return to mainline code + jmp LA444 ; write EOF block +; RUN handler - sets up some Extended Basic stuff to defaults at program start +XVEC18 ldd #0xba42 ; initialize PLAY volume + std VOLHI + lda #2 ; set PLAY tempo to 2, PLAY octave to 3 + sta TEMPO + sta OCTAVE + asla ; set default note length to 5 + sta NOTELN + clr DOTVAL ; don't do any note length extension + ldd ZERO ; initialize DRAW angle and scale to default 1 + std ANGLE + ldb #128 ; initialize horizontal and vertical default coordinates to the middle of the screen + std HORDEF + ldb #96 + std VERDEF + rts +; Command interpretation loop handler; we need to intercept this to implement TRON/TROFF +XVEC20 leas 2,s ; don't return to the mainline code +L82BB andcc #0xaf ; make sure interrupts are running + jsr LADEB ; do a BREAK/pause check + ldx CHARAD ; save input pointer + stx TINPTR + lda ,x+ ; get current input character + beq L82CF ; brif end of line + cmpa #': ; statement separator? + beq L82F1 ; brif so + jmp LB277 ; raise error we got here with extra junk +L82CF lda ,x++ ; get first byte of next line address + sta ENDFLG ; use it to set "END" flag to "END" + bne L82D8 ; brif not end of program + jmp LAE15 ; go do the "END" +L82D8 ldd ,x+ ; get line number of next line (and leave pointer one before line text) + std CURLIN ; set current line number + stx CHARAD ; save input pointer + lda TRCFLG ; are we tracing? + beq L82F1 ; brif not + lda #'[ ; show opening marker for TRON line number + jsr PUTCHR + lda CURLIN ; restore MSB of line number + jsr LBDCC ; show line number + lda #'] ; show closing marker for TRON line number + jsr PUTCHR +L82F1 jsr GETNCH ; get the start of the statement + tfr cc,b ; save status flags + cmpa #0x98 ; is it CSAVE? + beq L8316 ; brif so - go to Extended Basic patch (adds CSAVEM) + cmpa #0x97 ; is it CLOAD? + beq L8311 ; brif so - go to Extended Basic patch (adds multi-origin binaries) + tfr b,cc ; restore character status + jsr LADC6 ; go process command + bra L82BB ; restart interpretation loop +; Tokenizaton handler. This is actually a hack to intercept CLOAD and CSAVE during immediate mode by causing the +; tokenization routine to return to the interpretation loop above instead of the mainline interpretation loop. This +; is necessary because the first command encountered on a line in immediate mode is executed BEFORE the interpretation +; loop RAM hook is called. This patch doesn't actually affect tokenization itself at all. +XVEC23 ldx 2,s ; get return address of caller to the tokenizer + cmpx #LAC9D ; is it coming from immediate mode prior to executing the line? + bne L8310 ; brif not + ldx #L82F1 ; force return to Extended Basic's main loop patch above + stx 2,s +L8310 rts +; These two patches are set up this way so that control can be transferred back to the original Color Basic +; implementations if the Extended Basic addons are not triggered. +L8311 jsr L8C62 ; transfer control to Extended Basic's CLOAD handler + bra L82BB ; go do another command +L8316 bsr L831A ; go do Extended Basic's CSAVE handler + bra L82BB ; go do another command +; Extended Basic's CSAVE handler which implements CSAVEM (which Color Basic does not have) +L831A jsr GETNCH ; get character after CSAVE + cmpa #'M ; is it CSAVEM? + lbne CSAVE ; brif not - Color Basic can handle this + jsr GETNCH ; eat the "M" + jsr LA578 ; parse file name + bsr L836C ; get start address + stx CASBUF+13 ; save it in file header + bsr L836C ; get end address + cmpx 2,s ; compare to start address + lblo LB44A ; brif end address is before the start address + bsr L836C ; get execution address + stx CASBUF+11 ; put in file header + jsr GETCCH ; are we at the end of the commmand? + bne L8310 ; brif not + lda #2 ; file type to machine language + ldx ZERO ; set to binary and single block + jsr LA65F ; write header + clr FILSTA ; mark any open tape file closed + inc BLKTYP ; set block type to data + jsr WRLDR ; write a data leader + ldx 4,s ; get starting address +L834D stx CBUFAD ; set start of data address + lda #255 ; try a full length block by default + sta BLKLEN + ldd 2,s ; get ending address + subd CBUFAD ; see how much is left + bhs L835E ; brif we have more to write + leas 6,s ; clean up stack + jmp LA491 ; write EOF block +L835E cmpd #255 ; do we have a full block left? + bhs L8367 ; brif so + incb ; set block size to remainder + stb BLKLEN +L8367 jsr SNDBLK ; write a data block + bra L834D ; go see if we have more to write +L836C jsr SYNCOMMA ; make sure we have a comma + jsr LB73D ; evaluate unsigned expression to X + ldu ,s ; get return address + stx ,s ; save result on stack + tfr u,pc ; return to caller +; COS function +COS ldx #L83AB ; point to PI/2 constant + jsr LB9C2 ; add to argument ( cos(x) = sin((pi/2)+x) ) +L837E jmp SIN ; now calculate sin((pi/2)+x) +; TAN function. This is determined by the identity TAN(X) = SIN(X)/COS(X) +TAN jsr LBC2F ; save FPA0 in FPA3 + clr RELFLG ; reset quadrant flag + bsr L837E ; calculate SIN(x) + ldx #V4A ; save result in FPA5 + jsr LBC35 + ldx #V40 ; get back original argument + jsr LBC14 + clr FP0SGN ; force result positive + lda RELFLG ; get quadrant flag + bsr L83A6 ; calculate COS(x) + tst FP0EXP ; did we get 0 for COS(x) + lbeq LBA92 ; brif so - overflow + ldx #V4A ; point to sin(x) +L83A3 jmp LBB8F ; divide the sin(x) value by the cos(x) value +L83A6 pshs a ; save sign flag + jmp LBFA6 ; expand polynomial +L83AB fcb 0x81,0x49,0x0f,0xda,0xa2 ; pi/2 constant +; ATN function (inverse tangent). There are two calculation streams used to improve precision. +; One if the parameter is >= 1.0 and the other if it is < 1.0 +ATN lda FP0SGN ; get sign of argument + pshs a ; save it + bpl L83B8 ; brif positive + bsr L83DC ; flip sign of argument +L83B8 lda FP0EXP ; get exponent + pshs a ; save it + cmpa #0x81 ; exponent for 1.0 + blo L83C5 ; brif less - value is less than 1.0 + ldx #LBAC5 ; point to FP constant 1.0 + bsr L83A3 ; calculate reciprocal +L83C5 ldx #L83E0 ; point to polynomical coefficients + jsr LBEF0 ; expand polynomial + puls a ; get exponent of argument + cmpa #0x81 ; did we do a reciprocal calculation? + blo L83D7 ; brif not + ldx #L83AB ; subtract result from pi/2 if we did + jsr LB9B9 +L83D7 puls a ; get sign of original + tsta ; was it positive? + bpl L83DF ; brif so +L83DC jmp LBEE9 ; flip sign of result +L83DF rts +; Chebyshev modified taylor series coefficients for inverse tangent. Note that these diverge quite significantly +; from the standard taylor series after 1/9. The standard coefficients are 1/1,-1/3, 1/5, -1/7, 1/9, -1/11, and +; so on. These modified coefficients yield reasonable accuracy for the precision available, presumably with +; fewer coefficients. +L83E0 fcb 11 ; 12 coefficients + fcb 0x76,0xb3,0x83,0xbd,0xd3 ; -0.000684793912 + fcb 0x79,0x1e,0xf4,0xa6,0xf5 ; 0.00485094216 + fcb 0x7b,0x83,0xfc,0xb0,0x10 ; -0.0161117018 + fcb 0x7c,0x0c,0x1f,0x67,0xca ; 0.0342096381 + fcb 0x7c,0xde,0x53,0xcb,0xc1 ; -0.0542791328 + fcb 0x7d,0x14,0x64,0x70,0x4c ; 0.0724571965 + fcb 0x7d,0xb7,0xea,0x51,0x7a ; -0.0898023954 + fcb 0x7d,0x63,0x30,0x88,0x7e ; 0.110932413 + fcb 0x7e,0x92,0x44,0x99,0x3a ; -0.142839808 + fcb 0x7e,0x4c,0xcc,0x91,0xc7 ; 0.199999121 + fcb 0x7f,0xaa,0xaa,0xaa,0x13 ; -0.333333316 + fcb 0x81,0x00,0x00,0x00,0x00 ; 1.0 +; Chebyshev modified taylor series coefficients for the ln(x)/ln(2) (base 2 log of x) +L841D fcb 3 ; four coefficients + fcb 0x7f,0x5e,0x56,0xcb,0x79 ; 0.434255942 from (2/7)/ln(2) + fcb 0x80,0x13,0x9b,0x0b,0x64 ; 0.576584541 from (2/5)/ln(2) + fcb 0x80,0x76,0x38,0x93,0x16 ; 0.961800759 from (2/3)/ln(2) + fcb 0x82,0x38,0xaa,0x3b,0x20 ; 2.88539007 from 2/ln(2) +L8432 fcb 0x80,0x35,0x04,0xf3,0x34 ; 1/sqrt(2) +L8437 fcb 0x81,0x35,0x04,0xf3,0x34 ; sqrt(2) +L843C fcb 0x80,0x80,0x00,0x00,0x00 ; -0.5 +L8441 fcb 0x80,0x31,0x72,0x17,0xf8 ; ln(2) +; LOG function (natural log, ln) +; FP representation is of the form A*2^B. Thus, the log routine determines the value of +; ln(A*2^B). +; +; ln(A*2^B) = ln(A) + ln(2^B) = ln(A) + B*ln(2) = (ln(A)/ln(2) + B)*ln(2), OR: +; (log2(A) + B)*ln(2) +; Now if we write A as A*(sqrt(2)/sqrt(2)), we haven't changed anything so: +; (log2(A*sqrt(2)/sqrt(2)) + B)*ln(2) = (log2(A*sqrt(2)) - log2(sqrt(2)) + B) * ln(2) +; which gives: (-1/2 + log2(A*sqrt(2)) + B) * ln(2) +; +; Everything except log2(A*sqrt(2)) is either constant or trivial. +; +; What the actual code below feeds into the modified taylor series is actually: +; 1 - (sqrt(2)/(A + sqrt(2)) which algebra reveals to be (A*sqrt(2)-1)/(A*sqrt(2)+1) +; +; Thus, the code is using (A*sqrt(2)-1)/(A*sqrt(2)+1) instead of A*sqrt(2) as one would +; expect from the identities. However, the modified coefficients in the series above +; could be correcting for that or the introduced error was deemed acceptable. +; NOTE: this routine does NOT return 0 for LOG(1) +LOG jsr LBC6D ; get status of FPA0 + lble LB44A ; brif <= 0 - logarithms don't exist in that case + ldx #L8432 ; point to 1/sqrt(2) + lda FP0EXP ; get exponent of argument + suba #0x80 ; remove bias + pshs a ; save it for later + lda #0x80 ; force exponent to 0 (this turns FPA0 into A in the above description) + sta FP0EXP + jsr LB9C2 ; add 1/sqrt(2) to A + ldx #L8437 ; point to sqrt(2) + jsr LBB8F ; divide that by FPA0 + ldx #LBAC5 ; point to 1.0 + jsr LB9B9 ; subtract result from 1.0: Now FPA0 is 1-(sqrt(2)/(A+1/sqrt(2))) + ldx #L841D ; point to coefficients + jsr LBEF0 ; expand polynomial (calculate base 2 log of modified argument) + ldx #L843C ; point to -0.5 + jsr LB9C2 ; add result + puls b ; get original exponent back + jsr LBD99 ; add B to FPA0 + ldx #L8441 ; point to ln(2) + jmp LBACA ; multiply by ln(2) which gives us the result in base e +; SQR function (square root) - returns the principle root (positive) +SQR jsr LBC5F ; move argument to FPA1 (first argument for exponentiation) + ldx #LBEC0 ; point to 0.5 (exponent for square root) + jsr LBC14 ; set up second argument to exponentiation (the exponent) +; Exponentiation operator +; This is calculated as A^x = e^(x*ln(A)) where A is in FPA1 and x is in FPA0 +L8489 beq EXP ; do "EXP" if exponent is 0 (this will catch 0^0) + tsta ; check that the base is not 0 + bne L8491 ; brif base is not 0 + jmp LBA3A ; 0^(nonzero) is 0 +L8491 ldx #V4A ; save exponent (to FPA5) + jsr LBC35 + clrb ; result sign will default to positive + lda FP1SGN ; check if base is positive + bpl L84AC ; brif so + jsr INT ; convert exponent to integer + ldx #V4A ; point to original expoent + lda FP1SGN ; get sign of FPA1 + jsr LBCA0 ; compare original exponent with truncated one + bne L84AC ; brif not equal + coma ; flip sign + ldb CHARAC ; get LS byte of integer exponent (result sign flag) +L84AC jsr LBC4C ; copy FPA1 (base) to FPA0 (A = sign) + pshs b ; save result sign + jsr LOG ; get natural log of the base + ldx #V4A ; multiply the log by the exponent + jsr LBACA + bsr EXP ; now raise e to the resulting power + puls a ; get result sign + rora ; brif it was negative + lbcs LBEE9 ; brif negative - flip sign + rts +L84C4 fcb 0x81,0x38,0xaa,0x3b,0x29 ; 1.44269504 (correction factor for exponential function) +; Chebyshev modified taylor series coefficients for e^x +L84C9 fcb 7 ; eight coefficients + fcb 0x71,0x34,0x58,0x3e,0x56 ; 1/(7!*(CF^7)) + fcb 0x74,0x16,0x7e,0xb3,0x1b ; 1/(6!*(CF^6)) + fcb 0x77,0x2f,0xee,0xe3,0x85 ; 1/(5!*(CF^5)) + fcb 0x7a,0x1d,0x84,0x1c,0x2a ; 1/(4!*(CF^4)) + fcb 0x7c,0x63,0x59,0x58,0x0a ; 1/(3!*(CF^3)) + fcb 0x7e,0x75,0xfd,0xe7,0xc6 ; 1/(2!*(CF^2)) + fcb 0x80,0x31,0x72,0x18,0x10 ; 1/(1!*(CF^1)) + fcb 0x81,0x00,0x00,0x00,0x00 ; 1 +; EXP function (e^x) +EXP ldx #L84C4 ; point to correction factor + jsr LBACA ; multiply it + jsr LBC2F ; save corrected argument to FPA3 + lda FP0EXP ; get exponent of FPA0 + cmpa #0x88 ; is it too big? + blo L8504 ; brif not +L8501 jmp LBB5C ; to 0 (underflow) or overflow error +L8504 jsr INT ; convert argument to an integer + lda CHARAC ; get ls byte of integer + adda #0x81 ; was argument 127? if so, the OV error; adds bias + beq L8501 + deca ; adjust for the extra +1 above + pshs a ; save integer exponent + ldx #V40 ; get fractional part of argument + jsr LB9B9 + ldx #L84C9 ; point to coefficients + jsr LBEFF ; evaluate polynomial on the fractional part + clr RESSGN ; force result to be positive + puls a ; get back original exponent + jsr LBB48 ; add original exponent to the fractional result + rts +; FIX function (truncate/round toward 0) (NOTE: INT() always rounds down so INT(-0.5) gives -1 but FIX(-0.5) gives 0) +FIX jsr LBC6D ; get status of argument + bmi L852C ; brif negative +L8529 jmp INT ; do regular "int" if positive +L852C com FP0SGN ; flip the sign + bsr L8529 ; do "INT" on this + jmp LBEE9 ; flip the sign back +; EDIT command +EDIT jsr L89AE ; get line number + leas 2,s ; we're not going to return to the main loop +L8538 lda #1 ; "LIST" flag + sta VD8 ; set to list the line + jsr LAD01 ; find line number + lbcs LAED2 ; brif line wasn't found + jsr LB7C2 ; go unpack the line into the buffer + tfr y,d ; calculate the actual length of the line + subd #LINBUF+2 + stb VD7 ; save line length (it will only be 8 bits) +L854D ldd BINVAL ; get the line number + jsr LBDCC ; display it + jsr LB9AC ; put a space after it + ldx #LINBUF+1 ; point to iput uffer + ldb VD8 ; are we listing? + bne L8581 ; brif so +L855C clrb ; reset digit accumulator +L855D jsr L8687 ; get a keypress + jsr L90AA ; set carry if not numeric + bcs L8570 ; brif not a number + suba #'0 ; remove ASCII bias + pshs a ; save digit value + lda #10 ; multiply accumulator by 10 + mul + addb ,s+ ; add in new digit + bra L855D ; go check for another digit +L8570 subb #1 ; this converts 0 to 1, but *only* 0 to 1 + adcb #1 + cmpa #'A ; abort? + bne L857D ; brif not + jsr LB958 ; to a CR + bra L8538 ; restart EDIT process +L857D cmpa #'L ; list? + bne L858C ; brif not +L8581 bsr L85B4 ; list the line + clr VD8 ; reset to "not listing" + jsr LB958 ; do a CR + bra L854D ; start editing +L858A leas 2,s ; lose return address +L858C cmpa #0x0d ; ENTER? + bne L859D ; brif not + bsr L85B4 ; echo out the line +L8592 jsr LB958 ; do a CR + ldx #LINBUF+1 ; reset input pointer to start of buffer + stx CHARAD + jmp LACA8 ; join immediate mode to replace the line in the program +L859D cmpa #'E ; exit? + beq L8592 ; brif so - end edit with no echo + cmpa #'Q ; quit? + bne L85AB ; brif not + jsr LB958 ; do a CR + jmp LAC73 ; go to immediate mode with no fanfare - no changes saved +L85AB bsr L85AF ; go do commands + bra L855C ; go handle another command +L85AF cmpa #0x20 ; space? + bne L85C3 ; brif not + skip2 +L85B4 ldb #LBUFMX-1 ; display up to a whole line +L85B6 lda ,x ; get buffer chracter + beq L85C2 ; brif end of line + jsr PUTCHR ; output character + leax 1,x ; move to next character + decb ; done? + bne L85B6 ; brif not +L85C2 rts +L85C3 cmpa #'D ; delete? + bne L860F ; brif not +L85C7 tst ,x ; end of line? + beq L85C2 ; brif so - can't delete + bsr L85D1 ; remove a character + decb ; done all requested? + bne L85C7 ; brif not + rts +L85D1 dec VD7 ; account for character being removed + leay -1,x ; set pointer and compensate for increment below +L85D5 leay 1,y ; move to next character + lda 1,y ; get next character + sta ,y ; move it forward + bne L85D5 ; brif we didn't hit the end of the buffer + rts +L85DE cmpa #'I ; insert? + beq L85F5 ; brif so + cmpa #'X ; extend? + beq L85F3 ; brif so + cmpa #'H ; "hack"? + bne L8646 ; brif not + clr ,x ; mark current location as end of line + tfr x,d ; calculate new line length + subd #LINBUF+2 + stb VD7 ; save new length +L85F3 bsr L85B4 ; display the line +L85F5 jsr L8687 ; read a character + cmpa #0x0d ; ENTER? + beq L858A ; brif so - terminate entry + cmpa #0x1b ; ESC? + beq L8625 ; brif so - back to command mode + cmpa #0x08 ; backspace? + bne L8626 ; brif no + cmpx #LINBUF+1 ; are we at the start of the buffer? + beq L85F5 ; brif so - it's a no-op + bsr L8650 ; move pointer back one, do a BS + bsr L85D1 ; remove character from the buffer + bra L85F5 ; go handle more input +L860F cmpa #'C ; change? + bne L85DE ; brif not +L8613 tst ,x ; is there something to change? + beq L8625 ; brif not + jsr L8687 ; get a key stroke + bcs L861E ; brif valid key + bra L8613 ; try again if invalid key +L861E sta ,x+ ; put new character in the buffer + bsr L8659 ; echo it + decb ; changed number requested? + bne L8613 ; brif not +L8625 rts +L8626 ldb VD7 ; get length of line + cmpb #LBUFMX-1 ; at maximum line length? + bne L862E ; brif not + bra L85F5 ; process another input character +L862E pshs x ; save input pointer +L8630 tst ,x+ ; are we at the end of the line? + bne L8630 ; brif not +L8634 ldb ,-x ; get character before current pointer, move back + stb 1,x ; move it forward + cmpx ,s ; at the original buffer pointer? + bne L8634 ; brif not + leas 2,s ; remove saved buffer pointer + sta ,x+ ; save input character in newly made hole + bsr L8659 ; echo it + inc VD7 ; bump line length counter + bra L85F5 ; go handle more stuff +L8646 cmpa #0x08 ; backspace? + bne L865C ; brif not +L864A bsr L8650 ; move pointer back, echo BS + decb ; done enough of them? + bne L864A ; brif not + rts +L8650 cmpx #LINBUF+1 ; at start of buffer? + beq L8625 ; brif so + leax -1,x ; move pointer back + lda #0x08 ; character to echo - BS +L8659 jmp PUTCHR ; echo character to screen +L865C cmpa #'K ; "kill"? + beq L8665 ; brif so + suba #'S ; search? + beq L8665 ; brif so + rts +L8665 pshs a ; save kill/search flag + bsr L8687 ; read target + pshs a ; save search character +L866B lda ,x ; get current character in buffer + beq L8685 ; brif end of line - nothing more to search + tst 1,s ; is it KILL? + bne L8679 ; brif so + bsr L8659 ; echo the character + leax 1,x ; move ahead + bra L867C ; check next character +L8679 jsr L85D1 ; remove character from buffer +L867C lda ,x ; get character in buffer + cmpa ,s ; are we at the target? + bne L866B ; brif not + decb ; have we found enough of them? + bne L866B ; brif not +L8685 puls y,pc ; clean up stack and return to main EDIT routine +L8687 jsr LA171 ; get input from the generic input handler (will show the cursor) + cmpa #0x7f ; graphics (or DEL)? + bhs L8687 ; brif so - ignore it + cmpa #0x5f ; SHIFT-UP? + bne L8694 ; brif not + lda #0x1b ; replace with ESC +L8694 cmpa #0x0d ; carriage return? + beq L86A6 ; brif so (C=0) + cmpa #0x1b ; ESC + beq L86A6 ; brif so (C=0) + cmpa #0x08 ; backspace? + beq L86A6 ; brif so (C=0) + cmpa #32 ; control code? + blo L8687 ; brif control code - try again + orcc #1 ; set C for "valid" (printable) character +L86A6 rts +; TRON and TROFF commands +TRON skip1lda ; load flag with nonzero for trace enabled (and skip next) +TROFF clra ; clear flag for trace disabled + sta TRCFLG ; save trace status + rts +; POS function +POS lda DEVNUM ; get original device number + pshs a ; save it for later + jsr LA5AE ; fetch device number + jsr LA406 ; check for open file + jsr LA35F ; set up print parameters + ldb DEVPOS ; get current line position for the device + jmp LA5E4 ; return position in B as unsigned +; VARPTR function +VARPTRTOK jsr LB26A ; make sure we have ( + ldd ARYEND ; get address of end of arrays + pshs d ; save it + jsr LB357 ; parse variable descriptor + jsr LB267 ; make sure there is a ) + puls d ; get original end of arrays + exg x,d ; swap original end of arrays and the discovered variable pointer + cmpx ARYEND ; did array end move (variable created?) + bne L8724 ; brif so (FC error) + jmp GIVABF ; return the pointer (NOTE: as signed) +; MID$() assignment; note that this cannot make the string longer or shorter and if the replacement is shorter +; than the specified size, only the number of characters actually in the replacement will be used. +L86D6 jsr GETNCH ; eat the MID$ token + jsr LB26A ; force ( + jsr LB357 ; evaluate the variable + pshs x ; save variable descriptor + ldd 2,x ; point to start of original string + cmpd FRETOP ; is it in string space? + bls L86EB ; brif not + subd MEMSIZ ; is it still in string space (top end)? + bls L86FD ; brif so +L86EB ldb ,x ; get length of original string + jsr LB56D ; allocate space in string space + pshs x ; save pointer to string space + ldx 2,s ; get to original string descriptor + jsr LB643 ; move the string into string space + puls x,u ; get new string address and string descriptor + stx 2,u ; save new data address for the string + pshs u ; save descriptor address again +L86FD jsr LB738 ; evaluate ",start" + pshs b ; save start offset + tstb ; is start 0? + beq L8724 ; brif so - strings offsets are 1-based + ldb #255 ; default use the entire string + cmpa #') ; end of parameters? + beq L870E ; brif so + jsr LB738 ; evaluate ",length" +L870E pshs b ; save length + jsr LB267 ; make sure we have a ) + ldb #0xb3 ; make sure we have = + jsr LB26F + bsr L8748 ; evaluate replacement string + tfr x,u ; save replacement string address + ldx 2,s ; get original string descriptor + lda ,x ; get length of original string + suba 1,s ; subtract start position + bhs L8727 ; brif within the string - insert replacement +L8724 jmp LB44A ; raise illegal function call +L8727 inca ; A is now number of characters to the right of the position parameter + cmpa ,s ; compare to length desired + bhs L872E ; brif new length fits + sta ,s ; only use as much of the length as will fit +L872E lda 1,s ; get position offset + exg a,b ; swap replacement length and position + ldx 2,x ; point to original string address + decb ; we work with 0-based offsets + abx ; now X points to start of replacement + tsta ; replacing 0? + beq L8746 ; brif so - done + cmpa ,s ; is replacement shorter than the hole? + bls L873F ; brif so + lda ,s ; use copy the maximum number specified +L873F tfr a,b ; save number to move in B + exg u,x ; swap pointers so they are right for the routine + jsr LA59A ; copy string data +L8746 puls a,b,x,pc ; clean up stack and return +L8748 jsr LB156 ; evaluate expression + jmp LB654 ; make sure it's a string and return string details +; STRING$ function +STRING jsr LB26A ; make sure we have ( + jsr EVALEXPB ; evaluate repeat count (error if > 255) + pshs b ; save repeat count + jsr SYNCOMMA ; make sure there's a comma + jsr LB156 ; evaluate the thing to repeat + jsr LB267 ; make sure we have a ) + lda VALTYP ; is it string? + bne L8768 ; brif so + jsr LB70E ; get 8 bit character code + bra L876B ; use that +L8768 jsr LB6A4 ; get first character of string +L876B pshs b ; save repeat character + ldb 1,s ; get repeat count + jsr LB50F ; reserve space for the string + puls a,b ; get character and repeat count + beq L877B ; brif NULL string +L8776 sta ,x+ ; put character into string + decb ; put enough? + bne L8776 ; brif not +L877B jmp LB69B ; return the newly created string +; INSTR function +INSTR jsr LB26A ; evaluate ( + jsr LB156 ; evaluate first argument + ldb #1 ; default start position is 1 (start of string) + pshs b ; save start position + lda VALTYP ; get type of first argument + bne L879C ; brif string - use default starting position + jsr LB70E ; convert first argument into string offset + stb ,s ; save offset + beq L8724 ; brif starting at 0 - not allowed + jsr SYNCOMMA ; make sure there's a comma + jsr LB156 ; evaluate the search string + jsr LB146 ; make sure it *is* a string +L879C ldx FPA0+2 ; get search string descriptor + pshs x ; save it + jsr SYNCOMMA ; make sure we have a comma + jsr L8748 ; evalute the target string + pshs x,b ; save address and length of target string + jsr LB267 ; make sure we have a ) + ldx 3,s ; get search string address + jsr LB659 ; get string details + pshs b ; save search string length + cmpb 6,s ; compare length of search string to the start + blo L87D9 ; brif start position is beyond the search string - return 0 + lda 1,s ; get length of target string + beq L87D6 ; brif targetstring is NULL - match will be immediate + ldb 6,s ; get start position + decb ; zero-base it + abx ; now X points to the start position for the search +L87BE leay ,x ; point to start of search + ldu 2,s ; get target string pointer + ldb 1,s ; get targetlength + lda ,s ; get length of serach + suba 6,s ; see how much is left in searh + inca ; add one for "inclusivity" + cmpa 1,s ; do we have less than the target string? + blo L87D9 ; brif so - we obviously won't match +L87CD lda ,x+ ; compare a byte + cmpa ,u+ + bne L87DF ; brif no match + decb ; compared all of target? + bne L87CD ; brif not +L87D6 ldb 6,s ; get position where we matched + skip1 +L87D9 clrb ; flag no match + leas 7,s ; clean up stack + jmp LB4F3 ; return unsigned B +L87DF inc 6,s ; bump start position + leax 1,y ; move starting pointer + bra L87BE ; see if we match now +; Number parsing handler +XVEC19 cmpa #'& ; do we have & (hex or octal)? +L87E7 bne L8845 ; brif not + leas 2,s ; we won't return to the original invoker +L87EB clr FPA0+2 ; clear bottom of FPA0 for 16 bit value + clr FPA0+3 + ldx #FPA0+2 ; point to accumulator + jsr GETNCH ; eat the & + cmpa #'O ; octal? + beq L880A ; brif so + cmpa #'H ; hex? + beq L881F ; brif so + jsr GETCCH ; reset flags on input + bra L880C ; go process octal (default) +L8800 cmpa #'8 ; is it a valid octal character? + lbhi LB277 ; brif not (BUG: should be LBHS or above be #'7) + ldb #3 ; base 8 multiplier + bsr L8834 ; add digit to accumulator +L880A jsr GETNCH ; get input character +L880C bcs L8800 ; brif numeric +L880E clr FPA0 ; clear upper bytes of FPA0 + clr FPA0+1 + clr VALTYP ; result is numeric + clr FPSBYT ; clear out any extra precision + clr FP0SGN ; make it positive + ldb #0xa0 ; exponent for integer aligned to right of FPA0 + stb FP0EXP + jmp LBA1C ; go normalize the result and return +L881F jsr GETNCH ; get input character + bcs L882E ; brif digit + jsr LB3A2 ; set carry if not alpha +L8826 bcs L880E ; brif not alpha + cmpa #'G ; is it valid HEX digit? + bhs L880E ; brif not + suba #7 ; normalize A-F to be just above 0-9 +L882E ldb #4 ; four bits per digit + bsr L8834 ; add digit to accumlator + bra L881F ; process another digit +L8834 asl 1,x ; shift accumulator one bit left + rol ,x + lbcs LBA92 ; brif too big - overflow + decb ; done enough bit shifts? + bne L8834 ; brif not +L883F suba #'0 ; remove ASCII bias + adda 1,x ; merge digit into accumlator (this cannot cause carry) + sta 1,x +L8845 rts +; Expression evaluation handler +XVEC15 puls u ; get back return address + clr VALTYP ; set result to numeric + ldx CHARAD ; save input pointer + jsr GETNCH ; get the input character + cmpa #'& ; HEX or OCTAL? + beq L87EB ; brif so + cmpa #0xcc ; FN? + beq L88B4 ; brif so - do "FNx()" + cmpa #0xff ; function token? + bne L8862 ; brif not + jsr GETNCH ; get function token value + cmpa #0x83 ; USR? + lbeq L892C ; brif so - short circuit Color Basic's USR handler +L8862 stx CHARAD ; restore input pointer + jmp ,u ; return to mainline code +L8866 ldx CURLIN ; are we in immediate mode? + leax 1,x +L886A bne L8845 ; brif not - we're good + ldb #2*11 ; code for illegal direct statement +L886E jmp LAC46 ; raise error +; DEF command (DEF FN, DEF USR) +DEF ldx [CHARAD] ; get two input characters + cmpx #0xff83 ; USR? + lbeq L890F ; brif so - do DEF USR + bsr L88A1 ; get descriptor address for FN variable + bsr L8866 ; disallow DEF FN in immediate mode + jsr LB26A ; make sure we have ( + ldb #0x80 ; disallow arrays as arguments + stb ARYDIS + jsr LB357 ; evaluate variable + bsr L88B1 ; make sure it's numeric + jsr LB267 ; make sure we have ) + ldb #0xb3 ; make sure we have = + jsr LB26F + ldx V4B ; get variable descriptor address + ldd CHARAD ; get input pointer + std ,x ; save address of the actual function code in variable descriptor + ldd VARPTR ; get descriptor address of argument + std 2,x ; save argument descriptor address + jmp DATA ; move to the end of this statement +L88A1 ldb #0xcc ; make sure we have FN + jsr LB26F + ldb #0x80 ; disable array lookup + stb ARYDIS + ora #0x80 ; set bit 7 of first character (to indicate FN variable) + jsr LB35C ; find the variable + stx V4B ; save descriptor pointer +L88B1 jmp LB143 ; make sure we have a numeric variable +; Evaluate an FN call +L88B4 bsr L88A1 ; parse the FNx bit and get the descriptor + pshs x ; save descriptor + jsr LB262 ; evaluate parameter + bsr L88B1 ; make sure it's a number + puls u ; get FN descriptor + ldb #2*25 ; code for undefined function + ldx 2,u ; point to argument variable descriptor + beq L886E ; brif nothing doing there (if it was just created, this will be NULL) + ldy CHARAD ; save current input pointer + ldu ,u ; point to start of FN definition + stu CHARAD ; put input pointer there + lda 4,x ; save original value of argument and save it with current input, and variable pointers + pshs a + ldd ,x + ldu 2,x + pshs u,y,x,d + jsr LBC35 ; set argument variable to the argument +L88D9 jsr LB141 ; go evaluate the FN expression + puls d,x,y,u ; get back variable pointers, input pointer, and original variable value + std ,x + stu 2,x + puls a + sta 4,x + jsr GETCCH ; test end of FN formula + lbne LB277 ; brif not end of statement - problem with the function + sty CHARAD ; restore input pointer +L88EF rts +; Error handler +XVEC17 cmpb #2*25 ; is it a valid Extended Basic error code? + blo L88EF ; brif not - return to mainline + jsr LA7E9 ; turn off tape + jsr LA974 ; turn off sound + jsr LAD33 ; clean up stack and other bits + clr DEVNUM ; reset output to screen + jsr LB95C ; do a newline if needed + jsr LB9AF ; do a ? + ldx #L890B-25*2 ; point to error message table + jmp LAC60 ; go display error message +; Extended Basic error codes. Yes, NE is defined here even though it is only actually documented in the +; Disk Basic documentation. It is here for the use of DLOAD. +L890B fcc 'UF' ; 25 undefined function call + fcc 'NE' ; 26 File not found +; DEF USR +L890F jsr GETNCH ; eat the USR token + bsr L891C ; get pointer to USR call + pshs x ; save FN exec address location + bsr L8944 ; calculate execution address + puls u ; get FN address pointer + stx ,u ; save new address + rts +L891C clrb ; default routine number is 0 + jsr GETNCH ; fetch the call number + bcc L8927 ; brif not a number + suba #'0 ; remove ASCII bias + tfr a,b ; save it in the right place + jsr GETNCH ; eat the call number +L8927 ldx USRADR ; get start address of USR jump table + aslb ; two bytes per address + abx ; now X points to the right entry + rts +; Evaluate a USR call +L892C bsr L891C ; find the correct routine address location + ldx ,x ; get routine address + pshs x ; save it + jsr LB262 ; evaluate argument + ldx #FP0EXP ; point to FPA0 (argument value) + lda VALTYP ; is it string? + beq L8943 ; brif not + jsr LB657 ; fetch string details (removes it from the string stack) + ldx FPA0+2 ; get string descriptor pointer + lda VALTYP ; set flags for the value type +L8943 rts ; call the routine and return to mainline code +L8944 ldb #0xb3 ; check for "=" + jsr LB26F + jmp LB73D ; evaluate integer expression to X and return +; Extended Basic IRQ handler +XIRQSV lda PIA0+3 ; is it VSYNC interrupt? + bmi L8952 ; brif so + rti ; really should clear the HSYNC interrupt here +L8952 lda PIA0+2 ; clear VSYNC interrupt + ldx TIMVAL ; increment the TIMER value + leax 1,x + stx TIMVAL + jmp L9C3E ; check for other stuff +; TIMER= +L8960 jsr GETNCH ; eat the TIMER token + bsr L8944 ; evaluate =nnnn to X + stx TIMVAL ; set the timer + rts +; TIMER function +TIMER ldx TIMVAL ; get timer value + stx FPA0+2 ; set it in FPA0 + jmp L880E ; return as positive 16 bit value +; DEL command +DEL lbeq LB44A ; raise error if no argument (probably to avoid accidentally deleting line 0) + jsr LAF67 ; parse line number + jsr LAD01 ; find line + stx VD3 ; save address of line + jsr GETCCH ; is there something more? + beq L8990 ; brif not + cmpa #0xac ; dash? + bne L89BF ; brif not - error out + jsr GETNCH ; each the - + beq L898C ; brif no ending line - use default line number + bsr L89AE ; parse second line number and save in BINVAL + bra L8990 ; do the deletion +L898C lda #0xff ; set to maximum line number + sta BINVAL +L8990 ldu VD3 ; point end to start + skip2 +L8993 ldu ,u ; point to start of next line + ldd ,u ; check for end of program + beq L899F ; brif end of program + ldd 2,u ; get line number + subd BINVAL ; is it in range? + bls L8993 ; brif so +L899F ldx VD3 ; get starting line address + bsr L89B8 ; close up gap + jsr LAD21 ; reset input pointer and erase variables + ldx VD3 ; get start of program after the deletion + jsr LACF1 ; recompute netl ine pointers + jmp LAC73 ; return to immediate mode +L89AE jsr LAF67 ; parse a line number + jmp LA5C7 ; make sure there's nothing more +L89B4 lda ,u+ ; copy a byte + sta ,x+ +L89B8 cmpu VARTAB ; end of program? + bne L89B4 ; brif not + stx VARTAB ; save new start of variables/end of program +L89BF rts +; LINE INPUT +L89C0 jsr L8866 ; raise error if in immediate mode + jsr GETNCH ; eat the "INPUT" token + cmpa #'# ; device number? + bne L89D2 ; brif not + jsr LA5A5 ; parse device number + jsr LA3ED ; make sure it's valid for input + jsr SYNCOMMA ; make sure there's a comma after the device number +L89D2 cmpa #'" ; is there a prompt? + bne L89E1 ; brif not + jsr LB244 ; parse the string + ldb #'; ; make sure there's a semicolon after the prompt + jsr LB26F + jsr LB99F ; go actually display the prompt +L89E1 leas -2,s ; make a hole on the stack (so number of return adddresses is right) + jsr LB035 ; read an input line from current device + leas 2,s ; clean up stack + clr DEVNUM ; reset to screen/keyboard + jsr LB357 ; parse a variable + stx VARDES ; save pointer to it + jsr LB146 ; make sure it's a string + ldx #LINBUF ; point to input buffer + clra ; make sure we terminate on NUL only + jsr LB51A ; parse string and store it in string space + jmp LAFA4 ; go assign the string to its final resting place +; RENUM command +L89FC jsr LAF67 ; read a line number + ldx BINVAL ; get value + rts +L8A02 ldx VD1 ; get current old number being renumbered +L8A04 stx BINVAL ; save number being searched for + jmp LAD01 ; go find line number +RENUM jsr LAD26 ; erase variables + ldd #10 ; default line number interval and start + std VD5 ; set starting line number + std VCF ; set number interval + clrb ; now D is 0 + std VD1 ; save default start for renumbering + jsr GETCCH ; are there any arguments + bcc L8A20 ; brif not numeric + bsr L89FC ; fetch line number + stx VD5 ; save line beginning number + jsr GETCCH ; get input character +L8A20 beq L8A3D ; brif end of line + jsr SYNCOMMA ; make sure we have a comma + bcc L8A2D ; brif next isn't numeric + bsr L89FC ; fetch starting line number + stx VD1 ; save the number where we start working + jsr GETCCH ; fetch input character +L8A2D beq L8A3D ; brif end of line + jsr SYNCOMMA ; make sure we have a comma + bcc L8A3A ; brif we don't have a number + bsr L89FC ; parse the number + stx VCF ; save interval + beq L8A83 ; brif we ave a zero interval +L8A3A jsr LA5C7 ; raise error if more stuff +L8A3D bsr L8A02 ; get address of old number to process + stx VD3 ; save address + ldx VD5 ; get the next renumbered line to use + bsr L8A04 ; find that line + cmpx VD3 ; is it before the previous one? + blo L8A83 ; brif so - raise error + bsr L8A67 ; make sure renumbered line numbers will be in range + jsr L8ADD ; convert line numbers to "expanded" binary + jsr LACEF ; recalculate next line pointers + bsr L8A02 ; get address of first line to renumber + stx VD3 ; save it + bsr L8A91 ; make sure line numbers exist + bsr L8A68 ; renumber the actual lines + bsr L8A91 ; update line numbers in program text + jsr L8B7B ; convert packed binary line numbers to text + jsr LAD26 ; erase variables, reset stack, etc. + jsr LACEF ; recalculate next line pointers + jmp LAC73 ; bounce back to immediate mode +L8A67 skip1lda ; set line number flag to nonzero (skip next instruction) +L8A68 clra ; set line number flag to zero (insert new numbers) + sta VD8 ; save line number flag + ldx VD3 ; get address of line being renumbered + ldd VD5 ; get the current renumbering number + bsr L8A86 ; return if end of program +L8A71 tst VD8 ; test line number flag + bne L8A77 ; brif not adding new numbers + std 2,x ; set new number +L8A77 ldx ,x ; point to next line + bsr L8A86 ; return if end of program + addd VCF ; add interval to current number + bcs L8A83 ; brif we overflowed - bad line number + cmpa #MAXLIN ; maximum legal number? + blo L8A71 ; brif so - do another +L8A83 jmp LB44A ; raise FC error +L8A86 pshs d ; save D (we're going to clobber it) + ldd ,x ; get next line pointer + puls d ; unclobber D + bne L8A90 ; brif not end of program + leas 2,s ; return to caller's caller +L8A90 rts +L8A91 ldx TXTTAB ; get start of program + leax -1,x ; move pointer back one (compensate for leax 1,x below) +L8A95 leax 1,x ; move to next line + bsr L8A86 ; return if end of program +L8A99 leax 3,x ; move past next line address and line number, go one before line +L8A9B leax 1,x ; move to next character + lda ,x ; check input character + beq L8A95 ; brif end of line + stx TEMPTR ; save current pointer + deca ; is it start of packed numeric line number? + beq L8AB2 ; brif so + deca ; does line exist? + beq L8AD3 ; brif line number exists + deca ; not part of something to process? + bne L8A9B ; brif so +L8AAC lda #3 ; set 1st byte to 3 to indicate line number not existing + sta ,x+ + bra L8A99 ; go process another +L8AB2 ldd 1,x ; get MSB of line number + dec 2,x ; is MS byte zero? + beq L8AB9 ; brif not + clra ; set MS byte to 0 +L8AB9 ldb 3,x ; get LSB of line number + dec 4,x ; is it zero? + beq L8AC0 ; brif not + clrb ; clear byte +L8AC0 std 1,x ; save binary number + std BINVAL ; save trial number + jsr LAD01 ; find the line number +L8AC7 ldx TEMPTR ; get start of packed line + bcs L8AAC ; brif line number not found + ldd V47 ; get address of line number + inc ,x+ ; bump first byte to 2 (exists if checking) or 1 if inserting + std ,x ; save address of correct number + bra L8A99 ; go process more +L8AD3 clr ,x ; clear carry and first byte + ldx 1,x ; point to address of correct line + ldx 2,x ; get correct line number + stx V47 ; save it + bra L8AC7 ; insert into line +L8ADD ldx TXTTAB ; get beginning of program + bra L8AE5 +L8AE1 ldx CHARAD ; get input pointer + leax 1,x ; move it forward +L8AE5 bsr L8A86 ; return if end of program + leax 2,x ; move past line address +L8AE9 leax 1,x ; move forward +L8AEB stx CHARAD ; save input pointer +L8AED jsr GETNCH ; get an input character +L8AEF tsta ; is it actual 0? + beq L8AE1 ; brif end of line + bpl L8AED ; brif not a token + ldx CHARAD ; get input pointer + cmpa #0xff ; function? + beq L8AE9 ; brif so - ignore it (and following byte) + jsr RVEC22 ; do the RAM hook thing + cmpa #0xa7 ; THEN? + beq L8B13 ; brif so + cmpa #0x84 ; ELSE? + beq L8B13 ; brif so + cmpa #0x81 ; GO(TO|SUB)? + bne L8AED ; brif not - we don't have a line number + jsr GETNCH ; get TO/SUB + cmpa #0xa5 ; GOTO? + beq L8B13 ; brif so + cmpa #0xa6 ; GOSUB? + bne L8AEB ; brif not +L8B13 jsr GETNCH ; fetch character after token + bcs L8B1B ; brif numeric (line number) +L8B17 jsr GETCCH ; set flags on input character + bra L8AEF ; keep checking for line numbers +L8B1B ldx CHARAD ; get input pointer + pshs x ; save it + jsr LAF67 ; parse line number + ldx CHARAD ; get input pointer after line +L8B24 lda ,-x ; get character before pointer + jsr L90AA ; set C if numeric + bcs L8B24 ; brif not numeric + leax 1,x ; move pointer up + tfr x,d ; calculate size of line number + subb 1,s + subb #5 ; make sure at least 5 bytes + beq L8B55 ; brif exactly 5 bytes - no change + blo L8B41 ; brif less than 5 bytes + leau ,x ; move remainder of program backward + negb ; negate extra number of bytes (to subtract from X) + leax b,x ; now X is the correct position to move program to + jsr L89B8 ; shift program backward + bra L8B55 +L8B41 stx V47 ; save end of line number space (end of copy) + ldx VARTAB ; get end of program + stx V43 ; set source pointer + negb ; get positive difference + leax b,x ; now X is the top of the destination block + stx V41 ; set copy destination + stx VARTAB ; save new end of program + jsr LAC1E ; make sure enough room and make a hole in the program + ldx V45 ; get end address of destination block + stx CHARAD ; set input there +L8B55 puls x ; get starting address of the line number + lda #1 ; set "new number" flag + sta ,x + sta 2,x + sta 4,x + ldb BINVAL ; get MS byte of line number + bne L8B67 ; brif it is not zero + ldb #1 ; set to 1 if MSB is 0 + inc 2,x ; flag MSB as 0 +L8B67 stb 1,x ; set MSB of line number + ldb BINVAL+1 ; get LSB of number + bne L8B71 ; brif nonzero + ldb #1 ; set to 1 if LSB is 0 + inc 4,x ; flag LSB as 0 +L8B71 stb 3,x ; save LSB of line number + jsr GETCCH ; get input character + cmpa #', ; multiple line numbers? (ON GOTO, ON GOSUB) + beq L8B13 ; brif so - process another + bra L8B17 ; go look for more line numbers +L8B7B ldx TXTTAB ; point to start of program + leax -1,x ; move back (compensate for inc below) +L8B7F leax 1,x ; move forward + ldd 2,x ; get this line number + std CURLIN ; save it (for error message) + jsr L8A86 ; return if end of program + leax 3,x ; skip address and line number, stay one before line text +L8B8A leax 1,x ; move to next character +L8B8C lda ,x ; get input character + beq L8B7F ; brif end of line + deca ; valid line new line number? + beq L8BAE ; brif so + suba #2 ; undefined line? + bne L8B8A ; brif not + pshs x ; save line number pointer + ldx #L8BD9-1 ; show UL message + jsr STRINOUT + ldx ,s ; get input pointer + ldd 1,x ; get undefined line number + jsr LBDCC ; display line number + jsr LBDC5 ; print out "IN XXXX" + jsr LB958 ; do a newline + puls x ; get input pointer back +L8BAE pshs x ; save input pointer + ldd 1,x ; get binary value of line number + std FPA0+2 ; save it in FPA0 + jsr L880E ; adjust FPA0 as integer + jsr LBDD9 ; convert to text string + puls u ; get previous input pointer address + ldb #5 ; each expanded line uses 5 bytes +L8BBE leax 1,x ; move pointer forward (in string number) past sign + lda ,x ; do we have a digit? + beq L8BC9 ; brif not - end of number + decb ; mark a byte consumed + sta ,u+ ; put digit in program + bra L8BBE ; copy another digit +L8BC9 leax ,u ; point to address at end of text number + tstb ; did number fill whole space? + beq L8B8C ; brif so - move on + leay ,u ; save end of number pointer + leau b,u ; point to the end of the original expanded number + jsr L89B8 ; close up gap in program + leax ,y ; get end of line number pointer back + bra L8B8C ; go process more +L8BD9 fcn 'UL ' +; HEX$ function +HEXDOL jsr LB740 ; convert argument to positive integer + ldx #STRBUF+2 ; point to string buffer + ldb #4 ; convert 4 nibbles +L8BE5 pshs b ; save nibble counter + clrb ; clear digit accumulator + lda #4 ; do 4 shifts +L8BEA asl FPA0+3 ; shift a bit off the left of the value into low bits of B + rol FPA0+2 + rolb + deca ; done all shifts? + bne L8BEA ; brif not + tstb ; do we have a nonzero digit? + bne L8BFF ; brif so + lda ,s ; is it last digit? + deca + beq L8BFF ; brif so - keep the 0 + cmpx #STRBUF+2 ; is it a middle zero? + beq L8C0B ; brif not +L8BFF addb #'0 ; add ASCII bias + cmpb #'9 ; above 9? + bls L8C07 ; brif not + addb #7 ; adjust into alpha range +L8C07 stb ,x+ ; save digit in output + clr ,x ; make sure we have a NUL term +L8C0B puls b ; get back nibble counter + decb ; done all? + bne L8BE5 ; brif not + leas 2,s ; don't return mainline (we're returning a string) + ldx #STRBUF+1 ; point to start of converted number + jmp LB518 ; save string in string space, etc., and return it +; DLOAD command; this is eliminated on the Coco3. It was basically useless anyway so it was +; a good candidate to overwrite for some extra code space in the lower 16K of the internal +; ROM. Now, DLOAD functions as another entry into the RESET sequence. +DLOAD jsr LA429 ; close tape file +L8C1B orcc #0x50 ; make sure interrupts are disabled + lda #MC3+MC1 ; disable MMU, 32K internal ROM, not "coco" compatible + sta INIT0 + clr TYCLR ; go to ROM mapping mode + jmp SC000 ; transfer control to the "hidden" init code +L8C28 clr INT.FLAG ; set the interrupt flag to not valid + clr PIA1+3 ; disable cartridge interrupt +L8C2E lda #COCO+MMUEN+MC3+MC2 ; enable SCS, 16K split, MMU, COCO mode + sta INIT0 + clr TYCLR ; go to ROM mode +L8C36 rts +L8C37 pshs a,b,x ; save registers + ldx CURPOS ; get cursor position + ldb HRWIDTH ; hi-res mode? + lbne ALINK22 ; brif so + ldb 1,s ; restore B + jmp LA30E ; go back to mainline code +L8C46 pshs cc ; save Z + tst HRWIDTH ; hi-res? + beq L8C4F ; brif not + jmp ALINK23 ; go to hi-res handler +L8C4F puls cc ; get back Z + jmp LA913 ; go back to mainline code + nop + fcb 0xc7 ; junk byte (too few NOPs above) +; This returns to the remainder of the original ECB 1.1 DLOAD code + tstb ; ASCII? + beq L8C5F ; brif not - do error + jsr LAD19 ; clear out program + jmp LAC7C ; go read program +L8C5F jmp LA616 ; raise bad file mode +; CLOADM patch for Extended Basic +L8C62 jsr GETNCH ; get character after CLOAD + cmpa #'M ; CLOADM? + lbne CLOAD ; brif not - Color Basic's CLOAD can handle it + clr FILSTA ; close tape file + jsr GETNCH ; eat the "M" + jsr LA578 ; parse file name + jsr LA648 ; find the file + tst CASBUF+10 ; is it a chunked file? + lbeq LA505 ; brif not - Color Basic's CLOADM can handle it + ldu CASBUF+8 ; get file type and ASCII flag + dec DEVNUM ; set source device to tape + jsr LA635 ; go read the first block + tfr u,d ; put type and ASCII flag somewhere more useful +; NOTE: DLOADM comes here to do the final processing +L8C85 subd #0x200 ; is it binary and "machine language"? + bne L8C5F ; brif not - raise an error + ldx ZERO ; default load offset + jsr GETCCH ; is there any offset? + beq L8C96 ; brif not + jsr SYNCOMMA ; make sure there's a comma + jsr LB73D ; evaluate offset in X +L8C96 stx VD3 ; save offset + jsr LA5C7 ; raise error if more stuff follows +L8C9B bsr L8CC6 ; get type of "amble" + pshs a ; save it + bsr L8CBF ; read in block length + tfr d,y ; save it + bsr L8CBF ; read in load address + addd VD3 ; add in offset + std EXECJP ; save it as the execution address + tfr d,x ; put load address in a pointer + lda ,s+ ; get "amble" type + lbne LA42D ; brif postamble - close file +L8CB1 bsr L8CC6 ; read a data byte + sta ,x ; save in memory + cmpa ,x+ ; did it actually save? + bne L8CCD ; brif not RAM - raise error + leay -1,y ; done yet? + bne L8CB1 ; brif not + bra L8C9B ; look for another "amble" +L8CBF bsr L8CC1 ; read a character to B +L8CC1 bsr L8CC6 ; read character to A + exg a,b ; swap character with previously read one +L8CC5 rts +L8CC6 jsr LA176 ; read a character from input + tst CINBFL ; EOF? + beq L8CC5 ; brif not +L8CCD jmp LA619 ; raise I/O error if EOF +L8CD0 bsr L8D14 ; transmit file name + pshs b,a ; save file status + inca ; was file found? + beq L8CDD ; brif not + ldu ZERO ; zero U - first block + bsr L8CE4 ; read block + puls a,b,pc ; restore status and return +L8CDD ldb #2*26 ; code for NE error + jmp LAC46 ; raise error +L8CE2 ldu CBUFAD ; get block number +L8CE4 leax 1,u ; bump block number + stx CBUFAD ; save new block number + ldx #CASBUF ; use cassette buffer + jsr L8D7C ; read a block + jmp LA644 ; reset input buffer pointers +; Generic input handler for Extended Basic +XVEC4 lda DEVNUM ; get device number + cmpa #-3 ; DLOAD? + bne L8D01 ; brif not + leas 2,s ; don't return to mainline code + clr CINBFL ; reset EOF flag to not EOF + tst CINCTR ; anything available? + bne L8D02 ; brif so - fetch one + com CINBFL ; flag EOF +L8D01 rts +L8D02 pshs u,y,x,b ; save registers + ldx CINPTR ; get buffer pointer + lda ,x+ ; get character from buffer + pshs a ; save it for return + stx CINPTR ; save new input pointer + dec CINCTR ; account for byte removed from buffer + bne L8D12 ; brif buffer not empty + bsr L8CE2 ; go read a block +L8D12 puls a,b,x,y,u,pc ; restore registers, return value, and return +L8D14 clra ; clear attempt counter + pshs x,b,a ; make a hole for variables + leay ,s ; set up frame pointer + bra L8D1D ; go read block +L8D1B bsr L8D48 ; bump attempt counter +L8D1D lda #0x8a ; send file request control code + bsr L8D58 + bne L8D1B ; brif no echo or error + ldx #CFNBUF+1 ; point to file name +L8D26 lda ,x+ ; get file name characater + jsr L8E04 ; send it + cmpx #CFNBUF+9 ; end of file name? + bne L8D26 ; brif not + bsr L8D62 ; output check byte and look for response + bne L8D1B ; transmit name again if not ack + bsr L8D72 ; get file type (0xff is not found) + bne L8D1B ; brif error + sta 2,y ; save file type + bsr L8D72 ; read ASCII flag + bne L8D1B ; brif error + sta 3,y ; save ASCII flag + bsr L8D6B ; read check byte + bne L8D1B ; brif error + leas 2,s ; lose attempt counter and check byte + puls a,b,pc ; return file type and ascii flag +L8D48 inc ,y ; bump attempt counter + lda ,y ; get new count + cmpa #5 ; done 5 times? + blo L8D6A ; brif not + lda #0xbc ; send abort code + jsr L8E0C + jmp LA619 ; raise an I/O error +L8D58 pshs a ; save compare character + bsr L8DB8 ; send character + bne L8D60 ; brif read error + cmpa ,s ; does it match? (set Z if good) +L8D60 puls a,pc ; restore character and return +L8D62 lda 1,y ; get XOR check byte + bsr L8DB8 ; send it and read + bne L8D6A ; brif read error + cmpa #0xc8 ; is it ack? (set Z if so) +L8D6A rts +L8D6B bsr L8D72 ; read character from rs232 + bne L8D6A ; brif error + lda 1,y ; get check byte + rts +L8D72 bsr L8DBC ; read a character from rs232 + pshs a,cc ; save result (and flags) + eora 1,y ; accumulate xor checksum + sta 1,y + puls cc,a,pc ; restore byte, flags, and return +L8D7C clra ; reset attempt counter + pshs u,y,x,b,a ; make a stack frame + asl 7,s ; split block number into two 7 bit chuncks + rol 6,s + lsr 7,s + leay ,s ; set up frame pointer + bra L8D8B +L8D89 bsr L8D48 ; bump attempt counter +L8D8B lda #0x97 ; send block request code + bsr L8D58 + bne L8D89 ; brif error + lda 6,y ; send out block number (high bits first) + bsr L8E04 + lda 7,y + bsr L8E04 + bsr L8D62 ; send check byte and get ack + bne L8D89 ; brif error + bsr L8D72 ; read block size + bne L8D89 ; brif read error + sta 4,y ; save character count + ldx 2,y ; get buffer pointer + ldb #128 ; length of data block +L8DA7 bsr L8D72 ; read a data byte + bne L8D89 ; brif error + sta ,x+ ; save byte in buffer + decb ; done a whole block? + bne L8DA7 ; brif not + bsr L8D6B ; read check byte + bne L8D89 ; brif error + leas 4,s ; lose attempt counter, check byte, and buffer pointer + puls a,b,x,pc ; return with character count in A, clean rest of stack +L8DB8 clr 1,y ; clear check byte + bsr L8E0C ; output character +L8DBC clra ; clear attempt counter + pshs x,b,cc ; save registers and interrupt status + orcc #0x50 ; disable interrupts + lda TIMOUT ; get timout delay (variable) + ldx ZERO ; get constant timeout value +L8DC5 bsr L8DE6 ; get RS232 status + bcc L8DC5 ; brif "space" - waiting for "mark" +L8DC9 bsr L8DE6 ; get RS232 status + bcs L8DC9 ; brif "mark" - waiting for "space" (start bit) + bsr L8DF9 ; delay for half of bit time + ldb #1 ; set bit probe + pshs b ; save it + clra ; reset data byte +L8DD4 bsr L8DF7 ; wait one bit time + ldb PIA1+2 ; get input bit to carry + rorb + bcc L8DDE ; brif "space" (0) + ora ,s ; merge bit probe in +L8DDE asl ,s ; shift bit probe over + bcc L8DD4 ; brif we haven't done 8 bits + leas 1,s ; remove bit probe + puls cc,b,x,pc ; restore interrupts, registers, and return +L8DE6 ldb PIA1+2 ; get RS232 value + rorb ; put in C + leax 1,x ; bump timeout + bne L8DF6 ; brif nonzero + deca ; did the number of waits expire? + bne L8DF6 ; brif not + leas 2,s ; don't return - we timed out + puls cc,b,x ; restore interrupts and registers + inca ; clear Z (A was zero above) +L8DF6 rts +L8DF7 bsr L8DF9 ; do first half of bit delay then fall through for second +L8DF9 pshs a ; save register + lda DLBAUD ; get baud rate constant +L8DFD brn L8DFD ; do nothing - delay + deca ; time expired? + bne L8DFD ; brif not + puls a,pc ; restore register and return +L8E04 pshs a ; save character to send + eora 1,y ; accumulate chechsum + sta 1,y + puls a ; get character back +L8E0C pshs b,a,cc ; save registers and interrupt status + orcc #0x50 ; disable interrupts + bsr L8DF7 ; do a bit delay + bsr L8DF7 ; do another bit delay + clr PIA1 ; set output to space (start bit) + bsr L8DF7 ; do a bit delay + ldb #1 ; bit probe start at LSB + pshs b ; save bitprobe +L8E1D lda 2,s ; get output byte + anda ,s ; see what our current bit is + beq L8E25 ; brif output is 0 + lda #2 ; set output to "marking" +L8E25 sta PIA1 ; send bit + bsr L8DF7 ; do a bit delay + asl ,s ; shift bit probe + bcc L8E1D ; brif not last bit + lda #2 ; set output to marking ("stop" bit) + sta PIA1 + leas 1,s ; lose bit probe + puls cc,a,b,pc ; restore registers, interrupts, and return +; PRINT USING +; This is a massive block of code for something that has limited utility. It is *almost* flexible enough to +; be truly useful outside of a narrow range of use cases. Indeed, this comes in at about 1/8 of the total +; Extended Color Basic ROM. +; +; This uses several variables: +; VD5: pointer to format string descriptor +; VD7: next print item flag +; VD8: right digit counter +; VD9: left digit counter (or length of string argument) +; VDA: status byte (bits as follows): +; 6: force comma +; 5: force leading * +; 4: floating $ +; 3: pre-sign +; 2: post-sign +; 0: scientific notation +L8E37 lda #1 ; set length to use to 1 + sta VD9 +L8E3B decb ; consume character from format string + jsr L8FD8 ; show error flag if flags set + jsr GETCCH ; get input character + lbeq L8ED8 ; brif end of line - bail + stb VD3 ; save remaining string length + jsr LB156 ; evaluate the argument + jsr LB146 ; error if numeric + ldx FPA0+2 ; get descriptor for argument + stx V4D ; save it for later + ldb VD9 ; get length counter to use + jsr LB6AD ; get B bytes of string space (do a LEFT$) + jsr LB99F ; print the formatted string + ldx FPA0+2 ; get formatted string descriptor + ldb VD9 ; get requested length + subb ,x ; see if we have any left over +L8E5F decb ; have we got the right width? + lbmi L8FB3 ; brif so - go process more + jsr LB9AC ; output a space + bra L8E5F ; go see if we're done yet +L8E69 stb VD3 ; save current format string counter and pointer + stx TEMPTR + lda #2 ; initial spaces count = 2 (for the two %s) + sta VD9 ; save length counter +L8E71 lda ,x ; get character in string + cmpa #'% ; is it the end of the sequence? + beq L8E3B ; brif so - display requested part of the strign + cmpa #0x20 ; space? + bne L8E82 ; brif not + inc VD9 ; bump spaces count + leax 1,x ; move format pointer forward + decb ; consume character + bne L8E71 ; brif not end of format string +L8E82 ldx TEMPTR ; restore format string pointer + ldb VD3 ; get back format string length + lda #'% ; show % as debugging aid +L8E88 jsr L8FD8 ; send error indicator if flags set + jsr PUTCHR ; output character + bra L8EB9 ; go process more format string +; PRINT extension for USING +XVEC9 cmpa #0xcd ; USING? + beq L8E95 ; brif so + rts ; return to mainline code +; This is the main entry point for PRINT USING +L8E95 leas 2,s ; don't return to the mainline code + jsr LB158 ; evaluate the format string + jsr LB146 ; error if numeric + ldb #'; ; make sure there's a ; after the string + jsr LB26F + ldx FPA0+2 ; get format string descriptor + stx VD5 ; save it for later + bra L8EAE ; process format string +L8EA8 lda VD7 ; is there a print item? + beq L8EB4 ; brif not + ldx VD5 ; get back format string descriptor +L8EAE clr VD7 ; reset next print item flag + ldb ,x ; get length of format string + bne L8EB7 ; brif string is non-null +L8EB4 jmp LB44A ; raise FC error +L8EB7 ldx 2,x ; point to start of string +L8EB9 clr VDA ; clear status (new item) +L8EBB clr VD9 ; clear left digit counter + lda ,x+ ; get character from format string + cmpa #'! ; ! (use first character of string)? + lbeq L8E37 ; brif so + cmpa #'# ; digit? + beq L8F24 ; brif so - handle numeric + decb ; consume format character + bne L8EE2 ; brif not done + jsr L8FD8 ; show a "+" if any flags set - indicates error at end of string + jsr PUTCHR ; output format string character +L8ED2 jsr GETCCH ; get current input character + bne L8EA8 ; brif not end of statement + lda VD7 ; get next item flag +L8ED8 bne L8EDD ; brif more print items + jsr LB958 ; do newline +L8EDD ldx VD5 ; point to format string descriptor + jmp LB659 ; remove from string stack, etc., if appropriate (and return) +L8EE2 cmpa #'+ ; is it + (pre-sign)? + bne L8EEF ; brif not + jsr L8FD8 ; send a "+" if flags set + lda #8 ; flag for pre-sign + sta VDA ; set flags + bra L8EBB ; go interpret some more stuff +L8EEF cmpa #'. ; decimal? + beq L8F41 ; brif so - numeric + cmpa #'% ; % (show string)? + lbeq L8E69 ; brif so + cmpa ,x ; do we have two identical characters? +L8EFB bne L8E88 ; brif not - invalid format character + cmpa #'$ ; double $? + beq L8F1A ; brif so - floating $ + cmpa #'* ; double *? + bne L8EFB ; brif not + lda VDA ; get status byte + ora #0x20 ; enable * padding + sta VDA + cmpb #2 ; is $$ the last two? + blo L8F20 ; brif so + lda 1,x ; is it $ after? + cmpa #'$ + bne L8F20 ; brif not + decb ; consume the "$" + leax 1,x + inc VD9 ; add to digit counter * pad + $ counter +L8F1A lda VDA ; indicate floating $ + ora #0x10 + sta VDA +L8F20 leax 1,x ; consume the second format character + inc VD9 ; add one more left place +L8F24 clr VD8 ; clear right digit counter +L8F26 inc VD9 ; bump left digit counter + decb ; consume character + beq L8F74 ; brif end of string + lda ,x+ ; get next format character + cmpa #'. ; decimal? + beq L8F4F ; brif so + cmpa #'# ; digit? + beq L8F26 ; brif so + cmpa #', ; comma flag? + bne L8F5A ; brif not + lda VDA ; set commas flag + ora #0x40 + sta VDA + bra L8F26 ; handle more characters to left of decimal +L8F41 lda ,x ; get character after . + cmpa #'# ; digit? + lbne L8E88 ; brif not - invalid + lda #1 ; set right digit counter to 1 (for the .) + sta VD8 + leax 1,x ; consume the . +L8F4F inc VD8 ; add one to right digit counter + decb ; consume character + beq L8F74 ; brif end of format string + lda ,x+ ; get another format character + cmpa #'# ; digit? + beq L8F4F ; brif so +L8F5A cmpa #0x5e ; up arrow? + bne L8F74 ; brif not + cmpa ,x ; two of them? + bne L8F74 ; brif not + cmpa 1,x ; three of them? + bne L8F74 ; brif not + cmpa 2,x ; four of them? + bne L8F74 ; brif not + cmpb #4 ; string actually has the characters? + blo L8F74 ; brif not + subb #4 ; consome them + leax 4,x + inc VDA ; set scientific notation bit +L8F74 leax -1,x ; back up input pointer + inc VD9 ; add one digit for pre-sign force + lda VDA ; is it pre-sign? + bita #8 + bne L8F96 ; brif so + dec VD9 ; undo pre-sign adjustment + tstb ; end of string? + beq L8F96 ; brif so + lda ,x ; get next character + suba #'- ; post sign force? + beq L8F8F ; brif so + cmpa #'+-'- ; plus? + bne L8F96 ; brif not + lda #8 ; trailing + is a pre-sign force +L8F8F ora #4 ; add in post sign flag + ora VDA ; merge with flags + sta VDA + decb ; consume character +L8F96 jsr GETCCH ; do we have an argument + lbeq L8ED8 ; brif not + stb VD3 ; save format string length + jsr LB141 ; evluate numeric expression + lda VD9 ; get left digit counter + adda VD8 ; add in right digit counter + cmpa #17 ; is it more than 16 digits + decimal? + lbhi LB44A ; brif so - this is a problem + jsr L8FE5 ; format value according to settings + leax -1,x ; move buffer pointer back + jsr STRINOUT ; display formatted number string +L8FB3 clr VD7 ; reset next print item flag + jsr GETCCH ; get current input character + beq L8FC6 ; brif end of statement + sta VD7 ; set next print flag to nonzero + cmpa #'; ; list separator ;? + beq L8FC4 ; brif so + jsr SYNCOMMA ; require a comma between if not ; + bra L8FC6 ; process next item +L8FC4 jsr GETNCH ; munch the semicolon +L8FC6 ldx VD5 ; get format string descriptor + ldb ,x ; get length of string + subb VD3 ; subtract amount left after last item + ldx 2,x ; point to string address + abx ; move pointer to correct spot + ldb VD3 ; get remaining string length + lbne L8EB9 ; if we have more, interpret from there + jmp L8ED2 ; re-interpret from start if we hit the end +L8FD8 pshs a ; save character + lda #'+ ; "error" flag character + tst VDA ; did we have some flags set? + beq L8FE3 ; brif not + jsr PUTCHR ; output error flag +L8FE3 puls a,pc ; restore character and return +L8FE5 ldu #STRBUF+4 ; point to string buffer + ldb #0x20 ; blank space + lda VDA ; get flags + bita #8 ; pre-sign? + beq L8FF2 ; brif not + ldb #'+ ; plus sign +L8FF2 tst FP0SGN ; get sign of value + bpl L8FFA ; brif positive + clr FP0SGN ; make number positive (for later) + ldb #'- ; negative sign +L8FFA stb ,u+ ; put sign in buffer + ldb #'0 ; put a zero there + stb ,u+ + anda #1 ; check scientific notation force + lbne L910D ; brif so + ldx #LBDC0 ; point to FP 1E+9 + jsr LBCA0 ; is it less? + bmi L9023 ; brif so + jsr LBDD9 ; convert FP number to string (we're doing scientific notation) +L9011 lda ,x+ ; advance pointer to end of string + bne L9011 +L9015 lda ,-x ; make a hole at the start + sta 1,x + cmpx #STRBUF+3 ; done yet? + bne L9015 ; brif not + lda #'% ; put "overflow" flag at start + sta ,x + rts +L9023 lda FP0EXP ; get exponent of value + sta V47 ; save it + beq L902C ; brif value is 0 + jsr L91CD ; convert to number with 9 significant figures to left of decimal +L902C lda V47 ; get base 10 exponent offset + lbmi L90B3 ; brif < 100,000,000 + nega ; get negative difference + adda VD9 ; add to number of left digits + suba #9 ; account for the 9 we actually have + jsr L90EA ; put leading zeroes in buffer + jsr L9263 ; initialize the decimal point and comma counters + jsr L9202 ; convert FPA0 to decimal ASCII in buffer + lda V47 ; get base 10 exponent + jsr L9281 ; put that many zeroes in buffer, stop at decimal point + lda V47 ; get base 10 exponent + jsr L9249 ; check for decimal + lda VD8 ; get right digit counter + bne L9050 ; brif we want stuff after decimal + leau -1,u ; delete decimal if not needed +L9050 deca ; subtract one place (for decimal) + jsr L90EA ; put zeroes in buffer (trailing) +L9054 jsr L9185 ; insert * padding, floating $, and post-sign + tsta ; was there a post sign? + beq L9060 ; brif not + cmpb #'* ; was first character a *? + beq L9060 ; brif so + stb ,u+ ; store the post sign +L9060 clr ,u ; make srue it's NUL terminated + ldx #STRBUF+3 ; point to start of buffer +L9065 leax 1,x ; move to next character + stx TEMPTR ; save it for later + lda VARPTR+1 ; get address of decimal point + suba TEMPTR+1 ; subtract out actual digits left of decimal + suba VD9 ; subtract out required left digits + beq L90A9 ; brif no padding needed + lda ,x ; get current character + cmpa #0x20 ; space? + beq L9065 ; brif so - advance pointer + cmpa #'* ; *? + beq L9065 ; brif so - advance pointer + clra ; zero on stack is end of data ponter +L907C pshs a ; save character on stack + lda ,x+ ; get next character + cmpa #'- ; minus? + beq L907C ; brif so + cmpa #'+ ; plus? + beq L907C ; brif so + cmpa #'$ ; $? + beq L907C ; brif so + cmpa #'0 ; zero? + bne L909E ; brif not + lda 1,x ; get character after 0 + bsr L90AA ; clear carry if number + bcs L909E ; brif not number +L9096 puls a ; get character off stack + sta ,-x ; put it back in string buffer + bne L9096 ; brif not - restore another + bra L9065 ; keep cleaning up buffer +L909E puls a ; get the character on the stack + tsta ; is it NUL? + bne L909E ; brif not + ldx TEMPTR ; get string buffer start pointer + lda #'% ; put error flag in front + sta ,-x +L90A9 rts +L90AA cmpa #'0 ; zero? + blo L90B2 ; brif not + suba #'9+1 ; set C if > "9" + suba #-('9+1) +L90B2 rts +L90B3 lda VD8 ; get right digit counter + beq L90B8 ; brif not right digits + deca ; account for decimal point +L90B8 adda V47 ; add base 10 exponent offset + bmi L90BD ; if >= 0, no shifts are required + clra ; force shift counter to 0 +L90BD pshs a ; save shift counter +L90BF bpl L90CB ; brif positive count + pshs a ; save shift counter + jsr LBB82 ; divide FPA0 by 10 (shift 1 digit to the right) + puls a ; get shift counter back + inca ; account for the shift + bra L90BF ; see if we're done yet +L90CB lda V47 ; get base 10 exponent offset + suba ,s+ ; account for adjustment + sta V47 ; save new exponent offset + adda #9 ; account for significant places + bmi L90EE ; brif we don't need zeroes to left + lda VD9 ; get left decimal counter + suba #9 ; account for significant figures + suba V47 ; subtract exponent offset + bsr L90EA ; output leading zeroes + jsr L9263 ; initialize decimal and comma counters + bra L90FF ; process remainder of digits +L90E2 pshs a ; save zero counter + lda #'0 ; insert a 0 + sta ,u+ + puls a ; get back counter +L90EA deca ; do we need more zeroes? + bpl L90E2 ; brif so + rts +L90EE lda VD9 ; get left digit counter + bsr L90EA ; put that many zeroes in + jsr L924D ; put decimal in buffer + lda #-9 ; figure out filler zeroes + suba V47 + bsr L90EA ; output required leader zeroes + clr V45 ; clear decimal pointer counter + clr VD7 ; clear comma counter +L90FF jsr L9202 ; decode FPA0 to decimal string + lda VD8 ; get right digit counter + bne L9108 ; brif there are right digits + ldu VARPTR ; point to decimal location of decimal +L9108 adda V47 ; add base 10 exponent + lbra L9050 ; add in leading astrisks, etc. +L910D lda FP0EXP ; get exponent of FPA0 + pshs a ; save it + beq L9116 ; brif 0 + jsr L91CD ; convert to number with 9 figures +L9116 lda VD8 ; get right digit counter + beq L911B ; brif no right digits + deca ; account for decimal point +L911B adda VD9 ; get left digit counter + clr STRBUF+3 ; use buffer byte as temporary storage + ldb VDA ; get status flags + andb #4 ; post-sign? + bne L9129 ; brif so + com STRBUF+3 ; flip byte if no post sign +L9129 adda STRBUF+3 ; subtract 1 if no post sign + suba #9 ; account for significant figures + pshs a ; save shift counter +L9130 bpl L913C ; brif no more shifts needed + pshs a ; save counter + jsr LBB82 ; divide by 10 (shift right one) + puls a ; get back counter + inca ; account for the shift + bra L9130 ; see if we need more +L913C lda ,s ; get original shift count + bmi L9141 ; brif shifting happened + clra ; flag for no shifting +L9141 nega ; calculate position of decimal (negate shift count, add left digit and post sign if needed) + adda VD9 ; add left digit counter + inca ; and post sign + adda STRBUF+3 + sta V45 ; save decimal counter + clr VD7 ; clear comma counter + jsr L9202 ; convert to decimal string + puls a ; get shift counter + jsr L9281 ; put the needed zeroes in + lda VD8 ; get right digit counter + bne L915A ; brif we want some + leau -1,u ; remove te decimal point +L915A ldb ,s+ ; get original exponent + beq L9167 ; brif it was 0 + ldb V47 ; get base 10 exponent + addb #9 ; account for significant figures + subb VD9 ; remove left digit count + subb STRBUF+3 ; add one if post sign +L9167 lda #'+ ; positive sign + tstb ; is base 10 exponent positive? + bpl L916F ; brif so + lda #'- ; negative sign + negb ; flip exponent +L916F sta 1,u ; put exponent sign + lda #'E ; put "E" and advance output pointer + sta ,u++ + lda #'0-1 ; initialize digit accumulator +L9177 inca ; bump digit + subb #10 ; are we at the right digit? + bcc L9177 ; brif not + addb #'0+10 ; add ASCII bias and undo extra subtraction + std ,u++ ; save exponent in buffer + clr ,u ; clear final byte in buffer + jmp L9054 ; insert *, $, etc. +L9185 ldx #STRBUF+4 ; point to start of result + ldb ,x ; get sign + pshs b ; save it + lda #0x20 ; default pad with spaces + ldb VDA ; get flags + bitb #0x20 ; padding with *? + puls b + beq L919E ; brif no padding + lda #'* ; pad with * + cmpb #0x20 ; do we have a blank? (positive) + bne L919E ; brif not + tfr a,b ; use pad character +L919E pshs b ; save first character +L91A0 sta ,x+ ; store padding + ldb ,x ; get next character + beq L91B6 ; brif end of string + cmpb #'E ; exponent? + beq L91B6 ; brif so - treat as 0 + cmpb #'0 ; zero? + beq L91A0 ; brif so - pad it + cmpb #', ; leading comma? + beq L91A0 ; brif so - pad it + cmpb #'. ; decimal? + bne L91BA ; brif so - don't put a 0 before it +L91B6 lda #'0 ; put a zero before + sta ,-x +L91BA lda VDA ; get status byte + bita #0x10 ; floating $? + beq L91C4 ; brif not + ldb #'$ ; stuff a $ in + stb ,-x +L91C4 anda #4 ; pre-sgn? + puls b ; get back first character + bne L91CC ; brif not + stb ,-x ; save leading character (sign) +L91CC rts +L91CD pshs u ; save buffer pointer + clra ; initial exponent offset is 0 +L91D0 sta V47 ; save exponent offset + ldb FP0EXP ; get actual exponent + cmpb #0x80 ; is value >= 1.0? + bhi L91E9 ; brif so + ldx #LBDC0 ; point to FP number 1E9 + jsr LBACA ; multiply by 1000000000 + lda V47 ; account for 9 shifts + suba #9 + bra L91D0 ; brif not there yet +L91E4 jsr LBB82 ; divide by 10 + inc V47 ; account for shift +L91E9 ldx #LBDBB ; point to 999999999 + jsr LBCA0 ; compare it + bgt L91E4 ; brif not in range yet +L91F1 ldx #LBDB6 ; point to 99999999.9 + jsr LBCA0 ; compare + bgt L9200 ; brif in range + jsr LBB6A ; multiply by 10 + dec V47 ; account for shift + bra L91F1 ; see if we're in range yet +L9200 puls u,pc ; restore buffer pointer and return +L9202 pshs u ; save buffer pointer + jsr LB9B4 ; add .5 (round off) + jsr LBCC8 ; convert to integer format + puls u ; restore buffer pointer + ldx #LBEC5 ; point to 32 bit powers of 10 (alternating signs) + ldb #0x80 ; intitial digit counter is 0 with 0x80 bias +L9211 bsr L9249 ; check for comma +L9213 lda FPA0+3 ; add a 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 ; set V if carry and sign differ + rolb + bvc L9213 ; brif we haven't "wrapped" + bcc L9235 ; brif subtracting + subb #10+1 ; take 9's complement if adding + negb +L9235 addb #'0-1 ; add in ASCII bias + leax 4,x ; move to next power + tfr b,a ; save digit + anda #0x7f ; mask off subtract flag + sta ,u+ ; save digit + comb ; toggle add/subtract + andb #0x80 + cmpx #LBEE9 ; done all places? + bne L9211 ; brif not + clr ,u ; but NUL at end +L9249 dec V45 ; at decimal? + bne L9256 ; brif not +L924D stu VARPTR ; save decimal point pointer + lda #'. ; insert decimal + sta ,u+ + clr VD7 ; clear comma counter + rts +L9256 dec VD7 ; do we need a comma? + bne L9262 ; brif not + lda #3 ; reset comma counter + sta VD7 + lda #', ; insert comma + sta ,u+ +L9262 rts +L9263 lda V47 ; get base 10 exponent offset + adda #10 ; account for significant figures + sta V45 ; save decimal counter + inca ; add one for decimal point +L926A suba #3 ; divide by 3, leave remainder in A + bcc L926A + adda #5 ; renormalize to range 1-3 + sta VD7 ; save comma counter + lda VDA ; get status + anda #0x40 ; commas wanted? + bne L927A ; brif not + sta VD7 ; clear comma counter +L927A rts +L927B pshs a ; save zeroes counter + bsr L9249 ; check for decimal + puls a ; get back counter +L9281 deca ; need a zero? + bmi L928E ; brif not + pshs a ; save counter + lda #'0 ; put a zero + sta ,u+ + lda ,s+ ; get back counter and set flags + bne L927B ; brif not done enough +L928E rts +; From here to the end of the Extended Basic ROM is the PMODE graphics system and related +; infrastructure with the exception of the PLAY command which shares some of its machinery +; with the DRAW command. +; +; Fetch screen address calculation routine address for the selected graphics mode +L928F ldu #L929C ; point to normalization routine jump table + lda PMODE ; get graphics mode + asla ; two bytes per address + ldu a,u ; get routine address + rts +; Normalize VERBEG/HORBEG coordinates and return screen address in X and pixel mask in A. +L9298 bsr L928F ; fetch normalization routine pointer + jmp ,u ; transfer control to it +L929C fdb L92A6 ; PMODE 0 + fdb L92C2 ; PMODE 1 + fdb L92A6 ; PMODE 2 + fdb L92C2 ; PMODE 3 + fdb L92A6 ; PMODE 4 +; Two colour mode address calculatoin +L92A6 pshs u,b ; savce registers + ldb HORBYT ; get number of bytes in each graphics row + lda VERBEG+1 ; get vertical coordinate + mul + addd BEGGRP ; now D is the absolute address of the start of the row + tfr d,x ; get address to the return location + ldb HORBEG+1 ; get horizontal coordinate + lsrb ; divide by 8 (8 pixels per byte in 2 colour mode) + lsrb + lsrb + abx ; now X is the address of the actual pixel byte + lda HORBEG+1 ; get horizontal coordinate + anda #7 ; keep only the low 3 bits which contain the pixel number + ldu #L92DD ; point to pixel mask lookup + lda a,u ; get pixel mask + puls b,u,pc ; restore registers and return result +; four colour address calculation +L92C2 pshs u,b ; save registers + ldb HORBYT ; get bytes per graphics row + lda VERBEG+1 ; get vertical coordinate + mul + addd BEGGRP ; now D is the address of the start of the row + tfr d,x ; put it in returnlocatin + ldb HORBEG+1 ; get horizontal coordinate + lsrb ; divide by 4 (four colour modes have four pixels per byte) + lsrb + abx ; now X points to the screen byte + lda HORBEG+1 ; get horizontal coordinate + anda #3 ; keep low two bits for pixel number + ldu #L92E5 ; point to four colour pixel masks + lda a,u ; get pixel mask + puls b,u,pc ; restore registers and return result +L92DD fcb 0x80,0x40,0x20,0x10 ; two colour pixel masks + fcb 0x08,0x04,0x02,0x01 +L92E5 fcb 0xc0,0x30,0x0c,0x03 ; four colour pixel masks +; Move X down one graphics row +L92E9 ldb HORBYT ; get bytes per row + abx ; add to screen address + rts +; Move one pixel right in 2 colour mode +L92ED lsra ; move pixel mask right + bcc L92F3 ; brif same byte + rora ; move pixel mask to left of byte + leax 1,x ; move to next byte +L92F3 rts +; Move one pixel right in 4 colour mode +L92F4 lsra ; shift mask half a pixel right + bcc L92ED ; brif not past end of byte - shift one more + lda #0xc0 ; set mask on left of byte + leax 1,x ; move to next byte + rts +; Evaluate two expressions (coordinates). Put first in HORBEG and second in VERBEG. +L92FC jsr LB734 ; evaluate two expressions - first in BINVAL, second in B + ldy #HORBEG ; point to storage location +L9303 cmpb #192 ; is vertical outside range? + blo L9309 ; brif not + ldb #191 ; max it at bottom of screen +L9309 clra ; zero extend vertical coordinate + std 2,y ; save vertical coordinate + ldd BINVAL ; get horizontal coordinate + cmpd #256 ; in range? + blo L9317 ; brif so + ldd #255 ; max it out to right side of screen +L9317 std ,y ; save horizontal coordinate + rts +; Normalize coordinates for proper PMODE +L931A jsr L92FC ; parse coordinates +L931D ldu #HORBEG ; point to start coordinates +L9320 lda PMODE ; get graphics mode + cmpa #2 ; is it pmode 0 or 1? + bhs L932C ; brif not + ldd 2,u ; get vertical coordinate + lsra ; divide it by two + rorb + std 2,u ; save it back +L932C lda PMODE ; get graphics mode + cmpa #4 ; pmode 4? + bhs L9338 ; brif so + ldd ,u ; cut horizontal coordinate in half + lsra + rorb + std ,u ; save new coordinate +L9338 rts +; PPOINT function +PPOINT jsr L93B2 ; evaluate two expressions (coordinates) + jsr L931D ; normalize coordinates + jsr L9298 ; get screen address + anda ,x ; get colour value of desired screen coordinate + ldb PMODE ; get graphics mode + rorb ; is it a two colour m ode? + bcc L935B ; brif so +L9349 cmpa #4 ; is it on rightmost bits? + blo L9351 ; brif not + rora ; shift right + rora + bra L9349 ; see if we're there yet +L9351 inca ; colour numbers start at 1 + asla ; add in colour set (0 or 8) + adda CSSVAL + lsra ; get colour in range of 0 to 8 +L9356 tfr a,b ; put result to B + jmp LB4F3 ; return B as FP number +L935B tsta ; is pixel on? + beq L9356 ; brif not, return 0 (off) + clra ; set colour number to "1" + bra L9351 ; make it 1 or 5 and return +; PSET command +PSET lda #1 ; PSET flag + bra L9366 ; go turn on the pixel +; PRESET command +PRESET clra ; PRESET flag +L9366 sta SETFLG ; store whether we're setting or resetting + jsr LB26A ; enforce ( + jsr L931A ; evaluate coordinates + jsr L9581 ; evaluate colour + jsr LB267 ; enforce ) + jsr L9298 ; get address of pixel +L9377 ldb ,x ; get screen data + pshs b ; save it + tfr a,b ; duplicate pixel mask + coma ; invert mask + anda ,x ; turn off screen pixel + andb ALLCOL ; adjust pixel mask to be the current colour + pshs b ; merge pixel data into the screen data + ora ,s+ + sta ,x ; put it on screen + suba ,s+ ; nonzero if screen data changed + ora CHGFLG ; propagate change flag + sta CHGFLG + rts +; Evaluate two sets of coordinates separated by a minus sign. First at HORBEG,VERBEG and +; second at HOREND,VEREND. If no first set, use HORDEF,VERDEF. +L938F ldx HORDEF ; set default start coords + stx HORBEG + ldx VERDEF + stx VERBEG + cmpa #0xac ; do we start with a -? + beq L939E ; brif no starting coordinates + jsr L93B2 ; parse coordinates +L939E ldb #0xac ; make sure we have a - + jsr LB26F + jsr LB26A ; require a ( + jsr LB734 ; evaluate two expressions + ldy #HOREND ; point to storage location + jsr L9303 ; process coordinates + bra L93B8 ; finish up with a ) +L93B2 jsr LB26A ; make sure there's a ( + jsr L92FC ; evaluate coordinates +L93B8 jmp LB267 ; force a ) +; LINE command +LINE cmpa #0x89 ; is it LINE INPUT? + lbeq L89C0 ; brif so - go handle it + cmpa #'( ; starting coord? + beq L93CE ; brif so + cmpa #0xac ; leading -? + beq L93CE ; brif so + ldb #'@ ; if it isn't the above, make sure it's @ + jsr LB26F +L93CE jsr L938F ; parse coordinates + ldx HOREND ; set ending coordinates as the defaults + stx HORDEF + ldx VEREND + stx VERDEF + jsr SYNCOMMA ; make sure we have a comma + cmpa #0xbe ; PRESET? + beq L93E9 ; brif so + cmpa #0xbd ; PSET? + lbne LB277 ; brif not + ldb #01 ; PSET flag + skip1lda ; skip byte and set A nonzero +L93E9 clrb ; PRESET flag + pshs b ; save PSET/PRESET flag + jsr GETNCH ; eat the PSET/PRESET + jsr L9420 ; normalize coordinates + puls b ; get back PSET/PRESET flag + stb SETFLG ; flag which we're doing + jsr L959A ; set colour byte + jsr GETCCH ; get next bit + lbeq L94A1 ; brif no box option + jsr SYNCOMMA ; make sure it's comma + ldb #'B ; make sure "B" for "box" + jsr LB26F + bne L9429 ; brif something follows the B + bsr L9444 ; draw horizontal line + bsr L946E ; draw vertical line + ldx HORBEG ; save horizontal coordinate + pshs x ; save it + ldx HOREND ; switch in horizontal end + stx HORBEG + bsr L946E ; draw vertical line + puls x ; get back original start + stx HORBEG ; put it back + ldx VEREND ; do the same dance with the vertical end + stx VERBEG + bra L9444 ; draw horizontal line +L9420 jsr L931D ; normalize the start coordinates + ldu #HOREND ; point to end coords + jmp L9320 ; normalize those coordinates +L9429 ldb #'F ; make sure we have "BF" for "filled box" + jsr LB26F + bra L9434 ; fill the box +L9430 leax -1,x ; move vertical coordinate up one +L9432 stx VERBEG ; save new vertical coordinate +L9434 jsr L9444 ; draw a horizontal line + ldx VERBEG ; are we at the end of the box? + cmpx VEREND + beq L9443 ; brif so + bcc L9430 ; brif we're moving up the screen + leax 1,x ; move down the screen + bra L9432 ; go draw another line +L9443 rts +; Draw a horizontal line from HORBEG to HOREND at VERBEG using color mask in ALLCOL +L9444 ldx HORBEG ; get starting horizontal coordinate + pshs x ; save it + jsr L971D ; get absolute value of HOREND-HORBEG + bcc L9451 ; brif end is > start + ldx HOREND ; copy end coordinate to start it is smaller + stx HORBEG +L9451 tfr d,y ; save difference - it's a pixel count + leay 1,y ; coordinates are inclusive + jsr L9298 ; get screen position of start coord + puls u ; restore original start coordinate + stu HORBEG + bsr L9494 ; point to routine to move pizel pointers to right +L945E sta VD7 ; save pixel mask + jsr L9377 ; turn on pixel + lda VD7 ; get pixel mask back + jsr ,u ; move one pixel right + leay -1,y ; turned on enough pixels yet? + bne L945E ; brif not +L946B rts +L946C puls b,a ; clean up stack +L946E ldd VERBEG ; save original vertical start coordinate + pshs b,a + jsr L9710 ; get vertical difference + bcc L947B ; brif end coordinate > start + ldx VEREND ; swap in end coordinate if not + stx VERBEG +L947B tfr d,y ; save number of pixels to set + leay 1,y ; the coordinates are inclusive + jsr L9298 ; get screen pointer + puls u ; restore start coordinate + stu VERBEG + bsr L949D ; point to routine to move down one row + bra L945E ; draw vertical line +; Point to routine which will move one pixel right +L948A fdb L92ED ; PMODE 0 + fdb L92F4 ; PMODE 1 + fdb L92ED ; PMODE 2 + fdb L92F4 ; PMODE 3 + fdb L92ED ; PMODE 4 +L9494 ldu #L948A ; point to jump table + ldb PMODE ; get graphics mode + aslb ; two bytes per address + ldu b,u ; get jump address + rts +; Point to routine to move down one row +L949D ldu #L92E9 ; point to "move down one row" routien + rts +; Draw a line from HORBEG,VERBEG to HOREND,VEREND +L94A1 ldy #L950D ; point to increase vertical coord + jsr L9710 ; calculate difference + lbeq L9444 ; brif none - draw a horizontal line + bcc L94B2 ; brif vertical end is > vertical start + ldy #L951B ; point to decrease vertical coord +L94B2 pshs d ; save vertical difference + ldu #L9506 ; point to increase horizontal coord + jsr L971D ; get difference + beq L946C ; brif none - draw a vertical line + bcc L94C1 ; brif horizontal end > horizontal start + ldu #L9514 ; point to decrease hoizontal coord +L94C1 cmpd ,s ; compare vert and horiz differences + puls x ; get X difference + bcc L94CC ; brif horiz diff > vert diff + exg u,y ; swap change routine pointers + exg d,x ; swap differences +L94CC pshs u,d ; save larger difference and routine + pshs d ; save larger difference + lsra ; divide by two + rorb + bcs L94DD ; brif odd number + cmpu #L950D+1 ; increase or decrease? + blo L94DD ; brif increase + subd #1 ; back up one +L94DD pshs x,b,a ; save smallest difference and initial middle offset + jsr L928F ; point to proper coordinate to screen conversion routine +L94E2 jsr ,u ; convert coordinates to screen address + jsr L9377 ; turn on a pixel + ldx 6,s ; get distnace counter + beq L9502 ; brif line is completely drawn + leax -1,x ; account for one pixel drawn + stx 6,s ; save new counter + jsr [8,s] ; increment/decrement larger delta + ldd ,s ; get the minor coordinate increment counter + addd 2,s ; add the smallest difference + std ,s ; save new minor coordinate incrementcounter + subd 4,s ; subtractout the largest difference + bcs L94E2 ; brif not greater - draw another pixel + std ,s ; save new minor coordinate increment + jsr ,y ; adjust minor coordinate + bra L94E2 ; go draw another pixel +L9502 puls x ; clean up stack and return + puls a,b,x,y,u,pc +L9506 ldx HORBEG ; bump horizontal coordinate + leax 1,x + stx HORBEG + rts +L950D ldx VERBEG ; bump vertical coordinate + leax 1,x + stx VERBEG + rts +L9514 ldx HORBEG ; decrement horizontal coordinate + leax -1,x + stx HORBEG + rts +L951B ldx VERBEG ; decrement vertical coordinate + leax -1,x + stx VERBEG + rts +; Get normalized maximum coordinate values in VD3 and VD5 +L9522 ldu #VD3 ; point to temp storage + ldx #255 ; set maximum horizontal + stx ,u + ldx #191 ; set maximum vertical + stx 2,u + jmp L9320 ; normalize them +; PCLS command +PCLS beq L9542 ; clear to background colour if no argument + bsr L955A ; evaluate colour +L9536 lda #0x55 ; consider each byte as 4 groups of 2 bit sub-nibbles + mul ; now colour is in all four sub-pixels + ldx BEGGRP ; get start of graphics screen +L953B stb ,x+ ; set byte to proper colour + cmpx ENDGRP ; at end of graphics page? + bne L953B ; brif not + rts +L9542 ldb BAKCOL ; get background colour + bra L9536 ; do the clearing dance +; COLOR command +COLOR cmpa #', ; check for comma + beq L9552 ; brif no foreground colour + bsr L955A ; evaluate first colour + stb FORCOL ; set foreground colour + jsr GETCCH ; is there a background colour? + beq L9559 ; brif not +L9552 jsr SYNCOMMA ; make sure we have a comma + bsr L955A ; evaluate background colour argument + stb BAKCOL ; set background colour +L9559 rts +; Evaluate a colour agument and convert to proper code based on graphics mode +L955A jsr EVALEXPB ; evaluate colour code +L955D cmpb #9 ; is it in range of 0-8? + lbhs LB44A ; brif not - raise error + clra ; CSS value for first colour set + cmpb #5 ; is it first or second colour set? + blo L956C ; brif first colour set + lda #8 ; flag second colour set + subb #4 ; adjust into basic range +L956C pshs a ; save CSS value + lda PMODE ; get graphics mode + rora ; 4 colour or 2? + bcc L957B ; brif 2 colour + tstb ; was it 0? + bne L9578 ; brif not +L9576 ldb #4 ; if so, make it 4 +L9578 decb ; convert to zero based +L9579 puls a,pc ; get back CSS value and return +L957B rorb ; is colour number odd? + bcs L9576 ; brif so - force all bits set colour + clrb ; force colour 0 if not + bra L9579 +; Set all pixel byte and active colour +L9581 jsr L959A ; set colour byte + jsr GETCCH ; is there something to evaluate? + beq L9598 ; brif not + cmpa #') ; )? + beq L9598 ; brif so + jsr SYNCOMMA ; force comma + cmpa #', ; another comma? + beq L9598 ; brif so + jsr L955A ; evaluate expression and return colour + bsr L95A2 ; save colour and pixel byte +L9598 jmp GETCCH ; re-fetch input character and return +L959A ldb FORCOL ; use foreground colour by default + tst SETFLG ; doing PRESET? + bne L95A2 ; brif not + ldb BAKCOL ; default to background colour +L95A2 stb WCOLOR ; save working colour + lda #0x55 ; consider a byte as 4 pixels + mul ; now all pixels are set to the same bit pattern + stb ALLCOL ; set all pixels byte + rts +L95AA bne L95CF ; brif graphics mode +L95AC pshs x,b,a ; save registers + ldx #SAMREG+8 ; point to middle of control register + sta 10,x ; reset display page to 0x400 + sta 8,x + sta 6,x + sta 4,x + sta 2,x + sta 1,x + sta -2,x + sta -4,x ; reset to alpha mode + sta -6,x + sta -8,x + lda PIA1+2 ; set VDG to alpha mode, colour set 0 + anda #7 + sta PIA1+2 + puls a,b,x,pc ;restore registers and return +L95CF pshs x,b,a ; save registers + lda PMODE ; get graphics mode + adda #3 ; offset to 3-7 (we don't use the bottom 3 modes) + ldb #0x10 ; shift to high 4 bits + mul + orb #0x80 ; set to graphics mode + orb CSSVAL ; set the desired colour set + lda PIA1+2 ; get get original PIA values + anda #7 ; mask off VDG control + pshs a ; merge with new VDG control + orb ,s+ + stb PIA1+2 ; set new VDG mode + lda BEGGRP ; get start of graphics page + lsra ; divide by two - pages are on 512 byte boundaries + jsr L960F ; set SAM control register + lda PMODE ; get graphics mode + adda #3 ; shift to VDG values + cmpa #7 ; PMODE 4? + bne L95F7 ; brif not + deca ; treat PMODE 4 the same as PMODE 3 +L95F7 bsr L95FB ; program SAM's VDG bits + puls a,b,x,pc ; restore registers and return +L95FB ldb #3 ; set 3 bits in register + ldx #SAMREG ; point to VDG control bits +L9600 rora ; get bit to set + bcc L9607 ; brif we need to clear the bit + sta 1,x ; set the bit + bra L9609 +L9607 sta ,x ; clear the bit +L9609 leax 2,x ; move to next bit + decb ; done all bits? + bne L9600 ; brif not + rts +L960F ldb #7 ; 7 screen address bits + ldx #SAMREG+6 ; point to screen address bits in SAM + bra L9600 ; go program SAM bits +L9616 lda PIA1+2 ; get VDG bits + anda #0xf7 ; keep everything but CSS bit + ora CSSVAL ; set correct CSS bit + sta PIA1+2 ; set desired CSS + rts +; PMODE command +PMODETOK cmpa #', ; is first argument missing? + beq L9650 ; brif so + jsr EVALEXPB ; evaluate PMODE number + cmpb #5 ; valid (0-4)? + bhs L966D ; brif not + lda GRPRAM ; get start of graphics memory +L962E sta BEGGRP ; set start of graphics page + aslb ; multiply mode by two (table has two bytes per entry) + ldu #L9706+1 ; point to lookup table + adda b,u ; add in number of 256 byte pages used for graphics screen + cmpa TXTTAB ; does it fit? + bhi L966D ; brif not + sta ENDGRP ; save end of graphics + leau -1,u ; point to bytes per horizontal row + lda b,u ; get bytes per row + sta HORBYT ; set it + lsrb ; restore PMODE value + stb PMODE ; set graphics mode + clra ; set background colour to 0 + sta BAKCOL + lda #3 ; set foreground colour to maximum (3) + sta FORCOL + jsr GETCCH ; is there a starting page number? + beq L966C ; brif not +L9650 jsr LB738 ; evaluate an expression following a comma + tstb ; page 0? + beq L966D ; brif so - not valid + decb ; zero-base it + lda #6 ; each graphics page is 6*256 + mul + addb GRPRAM ; add to start of graphics memory + pshs b ; save start of screen memory + addb ENDGRP ; add current and address + subb BEGGRP ; subtract current start (adds size of screen) + cmpb TXTTAB ; does it fit? + bhi L966D ; brif not + stb ENDGRP ; save new end of graphics + puls b ; get back start of graphics + stb BEGGRP ; set start of graphics +L966C rts +L966D jmp LB44A ; raise FC error +; SCREEN command +SCREEN cmpa #', ; is there a mode? + beq L967F ; brif no mode + jsr EVALEXPB ; get mode argument + tstb ; set Z if alpha + jsr L95AA ; set SAM/VDG for graphics mode + jsr GETCCH ; is there a second argument? + beq L966C ; brif not +L967F jsr LB738 ; evaluate ,<expr> + tstb ; colour set 0? + beq L9687 ; brif so + ldb #8 ; flag for colour set 1 +L9687 stb CSSVAL ; set colour set + bra L9616 ; set up VDG +; PCLEAR command +PCLEAR jsr EVALEXPB ; evaulate number of pages requested + tstb ; 0? + beq L966D ; brif zero - not allowed + cmpb #9 ; more than 8? + bhs L966D ; brif so - not allowed + lda #6 ; there are 6 "pages" per graphics page + mul ; now B is the number of pages to reserve + addb GRPRAM ; add to start of graphics memory + tfr b,a ; now A is the MSB of the start of free memory + ldb #1 ; program memory always starts one above + tfr d,y ; save pointer to program memory + cmpd ENDGRP ; are we trying to deallocate the current graphics page? + blo L966D ; brif so (note that this prevents PCLEAR 0 anyway) + subd TXTTAB ; subtract out current start of basic program + addd VARTAB ; add in end of program - now D is new top of program + tfr d,x ; save new end of program + inca ; make some extra space (for stack) + subd FRETOP ; see if new top of program fits + bhs L966D ; brif there isn't enough space + jsr L80D0 ; adjust input pointer + nop ; space filler for 1.1 patch (the JSR above) + ldu VARTAB ; get end of program + stx VARTAB ; save new end of program + cmpu VARTAB ; is old end higher? + bhs L96D4 ; brif so +L96BD lda ,-u ; copy a byte upward + sta ,-x + cmpu TXTTAB ; at beginning? + bne L96BD ; brif not + sty TXTTAB ; save new start of program + clr -1,y ; there must always be a NUL before the program +L96CB jsr LACEF ; re-assign basic program addresses + jsr LAD26 ; reset variables and stack + jmp LAD9E ; return to interpretation loop +L96D4 ldu TXTTAB ; get start of program + sty TXTTAB ; save new start of program + clr -1,y ; there must be a NUL at the start of the program +L96DB lda ,u+ ; move a byte downward + sta ,y+ + cmpy VARTAB ; at the top of the program? + bne L96DB ; brif not + bra L96CB ; finish up +; Graphics initialization routine - this really should be up at the start of the ROM with the +; rest of the initialization code. +L96E6 ldb #0x1e ; set start of program to 0x1e00 ("PCLEAR 4") + stb TXTTAB + lda #6 ; graphics memory starts immediately after the screen +L96EC sta GRPRAM ; set graphics memory start + sta BEGGRP ; set start of current graphics page + clra ; set PMODE to 0 + sta PMODE + lda #16 ; 16 bytes per graphics row + sta HORBYT + lda #3 ; set foreground colour to 3 + sta FORCOL + lda #0x0c ; set ending graphics page (for PMODE 0) + sta ENDGRP + ldx TXTTAB ; get start of program + clr -1,x ; make sure there's a NUL before it +L9703 jmp LAD19 ; do a "NEW" +; PMODE data table (bytes per row and number of 256 byte pages required for a screen) +L9706 fcb 16,6 ; PMODE 0 + fcb 32,12 ; PMODE 1 + fcb 16,12 ; PMODE 2 + fcb 32,24 ; PMODE 3 + fcb 32,24 ; PMODE 4 +; Calculate absolute value of vertical coordinate difference +L9710 ldd VEREND ; get ending address + subd VERBEG ; get difference +L9714 bcc L9751 ; brif we didn't carry + pshs cc ; save status (C set if start > end) + jsr L9DC3 ; negate the difference to be positive + puls cc,pc ; restore C and return +; Calculate absolute value of horizontal coordinate difference +L971D ldd HOREND ; get end coordinate + subd HORBEG ; calculate difference + bra L9714 ; turn into absolute value +; PCOPY command +PCOPY bsr L973F ; fetch address of the source page + pshs d ; save address + ldb #0xa5 ; make sure we have TO + jsr LB26F + bsr L973F ; fetch address of the second page + puls x ; get back source + tfr d,u ; put destination into a pointer + ldy #0x300 ; 0x300 words to copy +L9736 ldd ,x++ ; copy a word + std ,u++ + leay -1,y ; done? + bne L9736 ; brif not + rts +L973F jsr EVALEXPB ; evaluate page number + tstb ; zero? + beq L9752 ; brif invalid page number +; BUG: this should be deferred until after the address is calculated at which point it should +; be bhs instead of bhi. There should also be a check to make sure the page number is less than +; or equal to 8 above so we don't have to test for overflows below. + cmpb TXTTAB ; is page number higher than start of program (BUG!) + bhi L9752 ; brif so - error + decb ; zero-base the page number + lda #6 ; 6 "pages" per graphics page + mul ; now we have proper number of "pages" for the offset + addb GRPRAM ; add start of graphics memory + exg a,b ; put MSB into A, 0 into B. +L9751 rts +L9752 jmp LB44A ; raise illegal function call +; GET command +GET clrb ; GET flag + bra L975A ; go on to the main body +PUT ldb #1 ; PUT flag +L975A stb VD8 ; save GET/PUT flag + jsr RVEC22 ; do the RAM hook dance (so Disk Basic can do its thing) +L975F cmpa #'@ ; @ before coordinates? + bne L9765 ; brif not + jsr GETNCH ; eat the @ +L9765 jsr L938F ; evaluate start/end coordinates + jsr SYNCOMMA ; make sure we have a comma + jsr L98CC ; get pointer to array + tfr X,D ; save descriptor pointer + ldu ,x ; get offset to next descriptor + leau -2,u ; move back to array name + leau d,u ; point to end of array + stu VD1 ; save end of data + leax 2,x ; point to number of dimensions + ldb ,x ; get dimension count + aslb ; two bytes per dimension size + abx ; now X points to start of data + stx VCF ; save start of array data + lda VALTYP ; is it numeric + bne L9752 ; brif not + clr VD4 ; set default graphic action to PSET + jsr GETCCH ; get input character + beq L97B7 ; brif no action flag + com VD4 ; flag action enabled + jsr SYNCOMMA ; make sure there's a comma + tst VD8 ; PUT? + bne L979A ; brif so + ldb #'G ; check for full graphics option + jsr LB26F + bra L97CA ; handle the rest of the process +L979A ldb #5 ; 5 legal actions for PUT + ldx #L9839 ; point to action table +L979F ldu ,x++ ; get "clear bit" action routine + ldy ,x++ ; get "set bit" action routine + cmpa ,x+ ; does token match? + beq L97AE ; brif so + decb ; checked all? + bne L979F ; brif not + jmp LB277 ; raise error +L97AE sty VD5 ; save set bit action address + stu VD9 ; save clear bit action address + jsr GETNCH ; munch the acton token + bra L97CA ; handle rest of process +L97B7 ldb #0xf8 ; mask for bottom three bits + lda PMODE ; get graphics mode + rora ; odd number mode? + bcc L97C0 ; brif even + ldb #0xfc ; bottom 2 bits mask +L97C0 tfr b,a ; save mask + andb HORBEG+1 ; round down the start address + stb HORBEG+1 + anda HOREND+1 ; round down end address + sta HOREND+1 +L97CA jsr L971D ; get horizontal size + bcc L97D3 ; brif end > start + ldx HOREND ; switch end in for start + stx HORBEG +L97D3 std HOREND ; save size + jsr L9710 ; calculate vertical size + bcc L97DE ; brif end > start + ldx VEREND ; swap in vertical end for the start + stx VERBEG +L97DE std VEREND ; save vertical size + lda PMODE ; get graphics mode + rora ; even? + ldd HOREND ; get difference + bcc L97EB ; brif even (2 colour) + addd HOREND ; add in size (double it) + std HOREND ; save adjusted end size +L97EB jsr L9420 ; normalize differences + ldd HOREND ; get end coord + ldx VEREND ; get end size + leax 1,x ; make vertical size inclusive + stx VEREND ; save it back + tst VD4 ; got "G" or GET action + bne L9852 ; brif given + lsra ; we're going for whole bytes here + rorb + lsra + rorb + lsra + rorb + addd #1 ; make it inclusive + std HOREND ; save new coordinate + jsr L9298 ; convert to screen address +L9808 ldb HOREND+1 ; get horizontal size + pshs x ; save screen position +L980C tst VD8 ; get/put flag + beq L9831 ; brif get + bsr L9823 ; bump array data pointer + lda ,u ; copy data from array to screen + sta ,x+ +L9816 decb ; are we done the row? + bne L980C ; brif not + puls x ; get screen address + jsr L92E9 ; move to next row + dec VEREND+1 ; done? + bne L9808 ; brif not +L9822 rts +L9823 ldu VCF ; get array data location + leau 1,u ; bump it + stu VCF ; save new array data location + cmpu VD1 ; did we hit the end of the array? + bne L9822 ; brif not +L982E jmp LB44A ; raise function call error +L9831 lda ,x+ ; get data from screen + bsr L9823 ; bump array data pointer + sta ,u ; put data in array + bra L9816 ; do the loopy thing +; PUT actions +L9839 fdb L9894,L989B ; PSET + fcb 0xbd + fdb L989B,L9894 ; PRESET + fcb 0xbe + fdb L98B1,L989B ; OR + fcb 0xb1 + fdb L9894,L98B1 ; AND + fcb 0xb0 + fdb L98A1,L98A1 ; NOT + fcb 0xa8 +L9852 addd #1 ; add to horiz difference + std HOREND ; save it + lda VD8 ; PUT? + bne L9864 ; brif so + ldu VD1 ; get end of array +L985D sta ,-u ; zero out a byte + cmpu VCF ; done? + bhi L985D ; brif not +L9864 jsr L9298 ; get screen address + ldb PMODE ; get graphics mode + rorb ; even? + bcc L986E ; brif so + anda #0xaa ; use as pixel mask for 4 colour mode +L986E ldb #1 ; set bit probe + ldy VCF ; point to start of array data +L9873 pshs x,a ; save screen address + ldu HOREND ; get horizontal size +L9877 pshs u,a ; save horizontal size and pixel mask + lsrb ; move bit probe right + bcc L9884 ; brif we didn't fall off a byte + rorb ; shift carry back in on the left + leay 1,y ; move ahead a byte in the array + cmpy VD1 ; end of array data? + beq L982E ; raise error if so +L9884 tst VD8 ; PUT? + beq L98A7 ; brif not + bitb ,y ; test bit in array + beq L9890 ; brif not set + jmp [VD5] ; do action routine for bit set +L9890 jmp [VD9] ; do action routine for bit clear +L9894 coma ; invert mask + anda ,x ; read screen data and reset the desired bit + sta ,x ; save on screen + bra L98B1 +L989B ora ,x ; merge pixel mask with screen data (turn on bit) + sta ,x ; save on screen + bra L98B1 +L98A1 eora ,x ; invert the pixel in the screen data + sta ,x ; save on screen + bra L98B1 +L98A7 bita ,x ; is the bit set? + beq L98B1 ; brif not - do nothing + tfr b,a ; get bit probe + ora ,y ; turn on proper bit in data + sta ,y +L98B1 puls a,u ; get back array address + jsr L92ED ; move screen address to the right + leau -1,u ; account for consumed pixel + cmpu ZERO ; done yet? + bne L9877 ; brif not + ldx 1,s ; get start of row back + lda HORBYT ; get number of bytes per row + leax a,x ; move ahead one line + puls a ; get back screen pixel mask + leas 2,s ; lose the screen pointer + dec VEREND+1 ; done all rows? + bne L9873 ; brif not + rts +L98CC jsr LB357 ; evaluate a variable + ldb ,-x ; get variable name + lda ,-x + tfr d,u ; save it + ldx ARYTAB ; get start of arrays +L98D7 cmpx ARYEND ; end of arrays? + lbeq LB44A ; brif not found + cmpu ,x ; correct variable? + beq L98E8 ; brif so + ldd 2,x ; get array size + leax d,x ; move to next array + bra L98D7 ; check this array +L98E8 leax 2,x ; move pointer to the array header + rts ; obviously this rts is not needed +L98EB rts +; PAINT command +PAINT cmpa #'@ ; do we have @ before coords? + bne L98F2 ; brif not + jsr GETNCH ; eat the @ +L98F2 jsr L93B2 ; evaluate coordinates + jsr L931D ; normalize coordinates + lda #1 ; PSET flag (use working colour) + sta SETFLG + jsr L9581 ; parse colour and set working colour, etc. + ldd WCOLOR ; get working colour and all pixels byte + pshs d ; save them + jsr GETCCH ; is there anything else? + beq L990A ; brif not + jsr L9581 ; evaluate border colour +L990A lda ALLCOL ; get border colour all pixel byte + sta VD8 ; save border colour pixel byte + puls d ; get back working colour details + std WCOLOR + clra ; store a "stop" frame on the stack so PAINT knows when it's finished unwinding + pshs u,x,b,a + jsr L9522 ; set up starting coordinates + jsr L928F ; point to pixel mask routine + stu VD9 ; save pixel mask routine + jsr L99DF ; paint from current horizontal coordinate to zero (left) + beq L9931 ; brif hit border immediately + jsr L99CB ; paint from current horizontal coordinate upward (right) + lda #1 ; set direction to "down" + sta VD7 + jsr L99BA ; save "down" frame + neg VD7 ; set direction to "up" + jsr L99BA ; save "up" frame +L9931 sts TMPSTK ; save stack pointer +L9934 tst CHGFLG ; did the paint change anything? + bne L993B ; brif so + lds TMPSTK ; get back stack pointer +L993B puls a,b,x,u ; get frame from stack + clr CHGFLG ; mark nothing changed + sts TMPSTK ; save stack pointer + leax 1,x ; move start coordinate right + stx HORBEG ; save new coordinate + stu VD1 ; save length of line + sta VD7 ; save up/down flag + beq L98EB ; did we hit the "stop" frame? + bmi L9954 ; brif negative going (up)? + incb ; bump vertical coordinate + cmpb VD6 ; at end? + bls L9958 ; brif not + clrb ; set vertical to 0 (wrap around) +L9954 tstb ; did we wrap? + beq L9934 ; do another block if so + decb ; move up a row +L9958 stb VERBEG+1 ; save vertical coordinate + jsr L99DF ; paint from horizontal to 0 + beq L996E ; brif we hit the border immediately + cmpd #3 ; less than 3 pixels? + blo L9969 ; brif so + leax -2,x ; move two pixels left + bsr L99A1 ; save paint block on the stack +L9969 jsr L99CB ; continue painting to the right +L996C bsr L99BA ; save paint data frame +L996E coma ; complement length of line just painted and add to length of line + comb +L9970 addd VD1 ; save difference between this line and parent line + std VD1 + ble L998C ; brif parent line is shorter + jsr L9506 ; bump horizontal coordinate + jsr L9A12 ; see if we bounced into the border + bne L9983 ; brif not border + ldd #-1 ; move left + bra L9970 ; keep looking +L9983 jsr L9514 ; move horizontally left + bsr L99C6 ; save horizontal coordinate + bsr L99E8 ; paint right + bra L996C ; save paint block and do more +L998C jsr L9506 ; bump horizontal coordinate + leax d,x ; point to right end of parent line + stx HORBEG ; set as curent coordinate + coma ; get amount we extend past parent line + comb + subd #1 + ble L999E ; brif doesn't extend + tfr d,x ; save length of line + bsr L99A1 ; save paint frame +L999E jmp L9934 +L99A1 std VCB ; save number of pixels painted + puls y ; get return address + ldd HORBEG ; get horizontal coordinate + pshs x,b,a ; save horizontal coordinate and pointer + lda VD7 ; get up/down flag + nega ; reverse it +L99AC ldb VERBEG+1 ; get vertical coordainte + pshs b,a ; save vertical coord and up/down flag + pshs y ; put return address back + ldb #2 ; make sure we haven't overflowed memory + jsr LAC33 + ldd VCB ; get line length back + rts +L99BA std VCB ; save length of painted line + puls y ; get return address + ldd HOREND ; get start coord + pshs x,b,a ; save horizontal start and length + lda VD7 ; get up/down flag + bra L99AC ; finish up with the stack +L99C6 ldx HORBEG ; save current horizontal coord and save it + stx HOREND + rts +L99CB std VCD ; save number of pixels painted + ldy HOREND ; get last horizontal start + bsr L99C6 ; save current coordinate + sty HORBEG ; save coordinate + bsr L99E8 ; paint a line + ldx VCD ; get number painted + leax d,x ; add to the number painted going the other way + addd #1 ; now D is length of line + rts +L99DF jsr L99C6 ; put starting coordinate in end + ldy #L9514 ; decrement horizontal coordinate address + bra L99EE ; go paint line +L99E8 ldy #L9506 ; increment horizontal coordinate address + jsr ,y ; bump coordinate +L99EE ldu ZERO ; initialize pixel count + ldx HORBEG ; get starting coordinate +L99F2 bmi L9A0B ; brif out of range for hoizontal coordinate + cmpx VD3 ; at end? + bhi L9A0B ; brif right of max + pshs u,y ; save counter and inc/dec routine pointer + bsr L9A12 ; at border? + beq L9A09 ; brif so + jsr L9377 ; set pixel to paint colour + puls y,u ; restore counter and inc/dec/pointer + leau 1,u ; bump number of painted pixels + jsr ,y ; inc/dec screen address + bra L99F2 ; go do another pixel +L9A09 puls y,u ; get back counter and inc/dec routine +L9A0B tfr u,d ; save count in D + tfr d,x ; and in X + subd ZERO ; set flags on D (smaller/faster than cmpd ZERO) + rts +L9A12 jsr [VD9] ; get the screen address + tfr a,b ; save pixel mask + andb VD8 ; set pixel to border colour + pshs b,a ; save mask and border + anda ,x ; mask current pixel into A + cmpa 1,s ; does it match border? Z=1 if so + puls a,b,pc ; restore mask, border pixel, and return +; PLAY command +; This is here mixed in with the graphics package because it shares some machinery with DRAW. +PLAY ldx ZERO ; default values for note length, etc. + ldb #1 + pshs x,b ; save default values + jsr LB156 ; evaluate argument + clrb ; enable DA and sound output + jsr LA9A2 + jsr LA976 +L9A32 jsr LB654 ; fetch PLAY string details + bra L9A39 ; go evaluate the string +L9A37 puls b,x ; get back play string details +L9A39 stb VD8 ; save length of string + beq L9A37 ; brif end of string + stx VD9 ; save start of string + lbeq LA974 ; brif NULL string - disable sound and return +L9A43 tst VD8 ; have anything left? + beq L9A37 ; brif not + jsr L9B98 ; get command character + cmpa #'; ; command separator? + beq L9A43 ; brif so - ignore it + cmpa #'' ; '? + beq L9A43 ; brif so - ignore it + cmpa #'X ; execuate sub string? + lbeq L9C0A ; brif so - handle it + bsr L9A5C ; handle other commands + bra L9A43 ; look for more stuff +L9A5C cmpa #'O ; octave? + bne L9A6D ; brif not + ldb OCTAVE ; get current octave + incb ; 1-base it + bsr L9AC0 ; get value if present + decb ; zero-base it + cmpb #4 ; valid octave? + bhi L9ACD ; raise error if not + stb OCTAVE ; save new octave + rts +L9A6D cmpa #'V ; volume? + bne L9A8B ; brif not + ldb VOLHI ; get current high volume limit + lsrb ; shift 2 bits right (DA is 6 bits in high bits) + lsrb + subb #31 ; subtract out mid value offset + bsr L9AC0 ; read argument + cmpb #31 ; maximum range is 31 + bhi L9ACD ; brif out of range + aslb ; adjust back in range + aslb + pshs b ; save new volume + ldd #0x7e7e ; midrange value for both high and low + adda ,s ; add new volume to high limit + subb ,s+ ; subtract volume from low limit + std VOLHI ; save new volume limits (sets high and low amplitudes) + rts +L9A8B cmpa #'L ; note length? + bne L9AB2 ; brif not + ldb NOTELN ; get current length + bsr L9AC0 ; read parameter + tstb ; resulting length 0? + beq L9ACD ; brif so - problem + stb NOTELN ; save new length + clr DOTVAL ; reset note timer scale factor +L9A9A bsr L9A9F ; check for dot + bcc L9A9A ; brif there was one + rts +L9A9F tst VD8 ; check length + beq L9AAD ; brif zero + jsr L9B98 ; get command character + cmpa #'. ; dot? + beq L9AAF ; brif so + jsr L9BE2 ; move input back and bump length +L9AAD coma ; set C to indicate nothing found + rts +L9AAF inc DOTVAL ; bump number of dots + rts +L9AB2 cmpa #'T ; tempo? + bne L9AC3 ; brif not + ldb TEMPO ; get current tempo + bsr L9AC0 ; parse tempo argument + tstb ; 0? + beq L9ACD ; brif so - invalid + stb TEMPO ; save new tempo + rts +L9AC0 jmp L9BAC ; evaluate various operators +L9AC3 cmpa #'P ; pause? + bne L9AEB ; brif not + jsr L9CCB ; evaluate parameter + tstb ; is the pause number 0? + bne L9AD0 ; brif not +L9ACD jmp LB44A ; raise FC error +L9AD0 lda DOTVAL ; save current volume and note scale + ldx VOLHI + pshs x,a + lda #0x7e ; drop DA to mid range + sta VOLHI + sta VOLLOW + clr DOTVAL + bsr L9AE7 ; go play a "silence" + puls a,x ; restore volume and note scale + sta DOTVAL + stx VOLHI + rts +L9AE7 clr ,-s ; set not number 0 + bra L9B2B ; go play it +L9AEB cmpa #'N ; N for "note"? + bne L9AF2 ; brif not - it's optional + jsr L9B98 ; skip the "N" +L9AF2 cmpa #'A ; is it a valid note? + blo L9AFA ; brif not + cmpa #'G ; is it above the note range? + bls L9AFF ; brif not - valid note +L9AFA jsr L9BBE ; evaluate a number + bra L9B22 ; process note value +L9AFF suba #'A ; normalize note number to 0 + ldx #L9C5B ; point to note number lookup table + ldb a,x ; get not number + tst VD8 ; any command characters left? + beq L9B22 ; brif not + jsr L9B98 ; get character + cmpa #'# ; sharp? + beq L9B15 ; brif so + cmpa #'+ ; also sharp? + bne L9B18 ; brif not +L9B15 incb ; add one half tone + bra L9B22 +L9B18 cmpa #'- ; flat? + bne L9B1F ; brif not + decb ; subtract one half tone + bra L9B22 +L9B1F jsr L9BE2 ; back up command pointer +L9B22 decb ; adjust note number (zero base it) + cmpb #11 ; is it valid? + bhi L9ACD ; raise error if not + pshs b ; save note value + ldb NOTELN ; get note length +L9B2B lda TEMPO ; get tempo value + mul ; calculate note duration + std VD5 ; save duration + leau 1,s ; point to where the stack goes after we're done + lda OCTAVE ; get current octave + cmpa #1 ; 0 or 1? + bhi L9B64 ; brif not + ldx #L9C62 ; point to delay table + ldb #2*12 ; 24 bytes per octave + mul ; now we have the base address + abx ; now X points to the octave base + puls b ; get back note value + aslb ; two bytes per delay + abx ; now we're pointing to the delay + leay ,x ; save pointer to note value + bsr L9B8C ; calculate note timer value + std PLYTMR ; set timer for note playing (IRQ will count this down) +L9B49 bsr L9B57 ; set to mid range and delay + lda VOLHI ; get high value + bsr L9B5A ; set to high value and delay + bsr L9B57 ; set to mid range and delay + lda VOLLOW ; get low value + bsr L9B5A ; set to low value and delay + bra L9B49 ; do it again (IRQ will break the loop) +L9B57 lda #0x7e ; mid value for DA with RS232 marking + nop ; a delay to fine tune frequencies +L9B5A sta PIA1 ; set DA + ldx ,y ; get delay value +L9B5F leax -1,x ; count down + bne L9B5F ; brif not done yet + rts +L9B64 ldx #L9C92-2*12 ; point to delay table for octaves 2+ + ldb #12 ; 12 bytes per octave + mul ; now we have the offset to the desired octave + abx ; now we point to the start of the octave + puls b ; get back note value + abx ; now we point to the delay value + bsr L9B8C ; calculate timer value + std PLYTMR ; set play timer (IRQ counts this down) +L9B72 bsr L9B80 ; send mid value and delay + lda VOLHI ; get high value + bsr L9B83 ; send high value and delay + bsr L9B80 ; send low value and delay + lda VOLLOW ; get low value + bsr L9B83 ; send low value and delay + bra L9B72 ; do it again (IRQ will break the loop) +L9B80 lda #0x7e ; mid range value with RS232 marking + nop ; fine tuning delay +L9B83 sta PIA1 ; set DA + lda ,x ; get delay value +L9B88 deca ; count down + bne L9B88 ; brif not done + rts +L9B8C ldb #0xff ; base timer value + lda DOTVAL ; get number of dots + beq L9B97 ; use default value if 0 + adda #2 ; add in constant timer factor + mul ; multiply scale by base + lsra ; divide by two - each increment will increase note timer by 128 + rorb +L9B97 rts +L9B98 pshs x ; save register +L9B9A tst VD8 ; do we have anything left? + beq L9BEB ; brif not - raise error + ldx VD9 ; get parsing address + lda ,x+ ; get character + stx VD9 ; save pointer + dec VD8 ; account for character consumed + cmpa #0x20 ; space? + beq L9B9A ; brif so - skip it + puls x,pc ; restore register and return +L9BAC bsr L9B98 ; get character + cmpa #'+ ; add one? + beq L9BEE ; brif so + cmpa #'- ; subtract one? + beq L9BF2 ; brif so + cmpa #'> ; double? + beq L9BFC ; brif so + cmpa #'< ; halve? + beq L9BF7 ; brif so +L9BBE cmpa #'= ; variable equate? + beq L9C01 ; brif so + jsr L90AA ; clear carry if numeric + bcs L9BEB ; brif not numeric + clrb ; initialize value to 0 +L9BC8 suba #'0 ; remove ASCII bias + sta VD7 ; save digit + lda #10 ; make room for digit + mul + tsta ; did we overflow 8 bits? + bne L9BEB ; brif so + addb VD7 ; add in digit + bcs L9BEB ; brif that overflowed + tst VD8 ; more digits? + beq L9BF1 ; brif not + jsr L9B98 ; get character + jsr L90AA ; clear carry if numeric + bcc L9BC8 ; brif another digit +L9BE2 inc VD8 ; unaccount for character just read + ldx VD9 ; move pointer back + leax -1,x + stx VD9 + rts +L9BEB jmp LB44A ; raise FC error +L9BEE incb ; bump param + beq L9BEB ; brif overflow +L9BF1 rts +L9BF2 tstb ; already zero? + beq L9BEB ; brif so - underflow + decb ; decrease parameter + rts +L9BF7 tstb ; already at 0? + beq L9BEB ; brif so - raise error + lsrb ; halve it + rts +L9BFC tstb ; will it overflow? + bmi L9BEB ; brif so + aslb ; double it + rts +L9C01 pshs u,y ; save registers + bsr L9C1B ; interpret command string as a variable + jsr LB70E ; convert it to an 8 bit number + puls y,u,pc ; restore registers and return +L9C0A jsr L9C1B ; evaluate expression in command string + ldb #2 ; room for 4 bytes? + jsr LAC33 + ldb VD8 ; get the command length and pointer + ldx VD9 + pshs x,b ; save them + jmp L9A32 ; go process the sub string +L9C1B ldx VD9 ; get command pointer + pshs x ; save it + jsr L9B98 ; get input character + jsr LB3A2 ; set carry if not alpha + bcs L9BEB ; brif not a variable reference +L9C27 jsr L9B98 ; get command character + cmpa #'; ; semicolon? + bne L9C27 ; keep scanning if not + puls x ; get back start of variable string + ldu CHARAD ; get current interpreter input pointer + pshs u ; save it + stx CHARAD ; point interpreter at command string + jsr LB284 ; evaluate expression as string + puls x ; restore interpeter input pointer + stx CHARAD + rts +; The bit of Extended Basic's IRQ routine that handles PLAY. Note that everything after +; clr PLYTMR+1 could be replaced with a simple lds 8,s followed by rts. +L9C3E clra ; make sure DP is set to 0 + tfr a,dp + ldd PLYTMR ; is PLAY running? + lbeq LA9BB ; brif not - transfer control on the Color Basic's routine + subd VD5 ; subtract out the interval + std PLYTMR ; save new timer value + bhi L9C5A ; brif it isn't <= 0 + clr PLYTMR ; disable the timer + clr PLYTMR+1 + puls a ; get saved CC + lds 7,s ; set stack to saved U value + anda #0x7f ; clear E flag (to return minimal state) + pshs a ; set fake "FIRQ" stack frame +L9C5A rti +L9C5B fcb 10,12,1,3,5,6,8 ; table of half tone numbers for notes A-G +L9C62 fdb 0x01a8,0x0190,0x017a,0x0164 ; delays for octave 1 + fdb 0x0150,0x013d,0x012b,0x011a + fdb 0x010a,0x00fb,0x00ed,0x00df + fdb 0x00d3,0x00c7,0x00bb,0x00b1 ; delays for octave 2 + fdb 0x00a6,0x009d,0x0094,0x008b + fdb 0x0083,0x007c,0x0075,0x006e +L9C92 fcb 0xa6,0x9c,0x93,0x8b ; delays for octave 3 + fcb 0x83,0x7b,0x74,0x6d + fcb 0x67,0x61,0x5b,0x56 + fcb 0x51,0x4c,0x47,0x43 ; delays for octave 4 + fcb 0x3f,0x3b,0x37,0x34 + fcb 0x31,0x2e,0x2b,0x28 + fcb 0x26,0x23,0x21,0x1f ; delays for octave 5 + fcb 0x1d,0x1b,0x19,0x18 + fcb 0x16,0x14,0x13,0x12 +; DRAW command +DRAW ldx ZERO ; create an empty "DRAW" frame + ldb #1 + pshs x,b + stb SETFLG ; set to "PSET" mode + stx VD5 ; clear update and draw flag + jsr L959A ; set active colour byte + jsr LB156 ; evaluate command string +L9CC6 jsr LB654 ; fetch command string details + bra L9CD3 ; interpret the command string +L9CCB jsr L9B98 ; fetch command character + jmp L9BBE ; evaluate a number +L9CD1 puls b,x ; get previously saved command string +L9CD3 stb VD8 ; save length counter + beq L9CD1 ; brif end of string + stx VD9 ; save pointer + lbeq L9DC7 ; brif overall end of command +L9CDD tst VD8 ; are we at the end of the string? + beq L9CD1 ; brif so - return to previous string + jsr L9B98 ; get command character + cmpa #'; ; semicolon? + beq L9CDD ; brif so - ignore it + cmpa #'' ; '? + beq L9CDD ; brif so - ignore that too + cmpa #'N ; update position toggle? + bne L9CF4 ; brif not + com VD5 ; toggle update position flag + bra L9CDD ; get on for another command +L9CF4 cmpa #'B ; blank flag? + bne L9CFC ; brif not + com VD6 ; toggle blank flag + bra L9CDD ; get on for another command +L9CFC cmpa #'X ; substring? + lbeq L9D98 ; brif so - execute command + cmpa #'M ; move draw position? + lbeq L9E32 ; brif so + pshs a ; save command character + ldb #1 ; default value if no number follows + tst VD8 ; is there something there? + beq L9D21 ; brif not + jsr L9B98 ; get character + jsr LB3A2 ; set C if not alpha + pshs cc ; save alpha state + jsr L9BE2 ; move back pointer + puls cc ; get back alpha flag + bcc L9D21 ; brif it's alpha + bsr L9CCB ; evaluate a number +L9D21 puls a ; get command back + cmpa #'C ; color change? + beq L9D4F ; brif so + cmpa #'A ; angle? + beq L9D59 ; brif so + cmpa #'S ; scale? + beq L9D61 ; brif so + cmpa #'U ; up? + beq L9D8F ; brif so + cmpa #'D ; down? + beq L9D8C ; brif so + cmpa #'L ; left? + beq L9D87 ; brif so + cmpa #'R ; right? + beq L9D82 ; brif so + suba #'E ; normalize the half cardinals to 0 + beq L9D72 ; brif E (45°) + deca ; F (135°?) + beq L9D6D ; brif so + deca ; G (225°?) + beq L9D7B ; brif so + deca ; H (315°?) + beq L9D69 ; brif so +L9D4C jmp LB44A ; raise FC error +L9D4F jsr L955D ; adjust colour for PMODE + stb FORCOL ; save new foreground colour + jsr L959A ; set up working colour and all pixels byte +L9D57 bra L9CDD ; go process another command +L9D59 cmpb #4 ; only 3 angles are valid + bhs L9D4C ; brif not valid + stb ANGLE ; save new angle + bra L9D57 ; go process another command +L9D61 cmpb #63 ; only 64 scale values are possible + bhs L9D4C ; brif out of range + stb SCALE ; save new scale factor + bra L9D57 ; go process another command +L9D69 clra ; make horizontal negative + bsr L9DC4 + skip1 +L9D6D clra ; keep horizontal distance positive + tfr d,x ; make horizontal distance and vertical distance the same + bra L9DCB ; go do the draw thing +L9D72 clra ; zero extend horizontal distance + tfr d,x ; set it as vertical + bsr L9DC4 ; negate horizontal distance + exg d,x ; swap directions (vertical is now negative) + bra L9DCB ; go do the draw thing +L9D7B clra ; zero extend horizontal distance + tfr d,x ; copy horizontal to vertical + bsr L9DC4 ; negate horizontal + bra L9DCB ; go do the drawing thing +L9D82 clra ; zero extend horizontal distance +L9DB3 ldx ZERO ; no vertical distance + bra L9DCB ; go do the drawing things +L9D87 clra ; zero extend horizontal + bsr L9DC4 ; negate horizontal + bra L9DB3 ; zero out vertical and do the drawing thing +L9D8C clra ; zero extend distance + bra L9D92 ; make the distance vertical and zero out horizontal +L9D8F clra ; zero extend distance + bsr L9DC4 ; negate distance +L9D92 ldx ZERO ; zero out vertical distance + exg x,d ; swap vertical and horizontal + bra L9DCB ; go do the drawing thing +L9D98 jsr L9C1B ; evaluate substring expression + ldb #2 ; is there enough room for the state? + jsr LAC33 + ldb VD8 ; save current command string state + ldx VD9 + pshs x,b + jmp L9CC6 ; go evaluate the sub string +L9DA9 ldb SCALE ; get scale factor + beq L9DC8 ; brif zero - default to full size + clra ; zero extend + exg d,x ; put distance somewhere useful + sta ,-s ; save MS of distance + bpl L9DB6 ; brif positive distance + bsr L9DC3 ; negate the distance +L9DB6 jsr L9FB5 ; multiply D and X + tfr u,d ; save ms bytes in D + lsra ; divide by 2 + rorb +L9DBD lsra ; ...divide by 4 + rorb + tst ,s+ ; negative distance? + bpl L9DC7 ; brif it was positive +L9DC3 nega ; negate D +L9DC4 negb + sbca #0 +L9DC7 rts +L9DC8 tfr x,d ; copy unchanged sitance to D + rts +L9DCB pshs b,a ; save horizontal distance + bsr L9DA9 ; apply scale factor to vertical + puls x ; get horizontal distance + pshs b,a ; save scaled vertical + bsr L9DA9 ; apply scale to horizontal + puls x ; get back vertical distance + ldy ANGLE ; get draw angle and scale + pshs y ; save them +L9DDC tst ,s ; is there an angle? + beq L9DE8 ; brif no angle + exg x,d ; swap distances + bsr L9DC3 ; negate D + dec ,s ; account for one tick around the rotation + bra L9DDC ; see if we're there yet +L9DE8 puls y ; get angle and scale back + ldu ZERO ; default end position (horizontal) is 0 + addd HORDEF ; add default horizontal to horizontal distance + bmi L9DF2 ; brif we went negative + tfr d,u ; save calculated end coordindate +L9DF2 tfr x,d ; get vertical distance somewhere useful + ldx ZERO ; default vertical end is 0 + addd VERDEF ; add distance to default vertical start + bmi L9DFC ; brif negative - use 0 + tfr d,x ; save calculated end coordinate +L9DFC cmpu #256 ; is horizontal in range? + blo L9E05 ; brif su + ldu #255 ; maximize it +L9E05 cmpx #192 ; is vertical in range? + blo L9E0D ; brif so + ldx #191 ; maximize it +L9E0D ldd HORDEF ; set starting coordinates for the line + std HORBEG + ldd VERDEF + std VERBEG + stx VEREND ; set end coordinates + stu HOREND + tst VD5 ; are we updating position? + bne L9E21 ; brif not + stx VERDEF ; update default coordinates + stu HORDEF +L9E21 jsr L9420 ; normalize coordindates + tst VD6 ; are we drawing something? + bne L9E2B ; brif not + jsr L94A1 ; draw the line +L9E2B clr VD5 ; reset draw and update flags + clr VD6 + jmp L9CDD ; do another command +L9E32 jsr L9B98 ; get a command character + pshs a ; save it + jsr L9E5E ; evaluate horizontal distance + pshs b,a ; save it + jsr L9B98 ; get character + cmpa #', ; comma between coordinates? + lbne L9D4C ; brif not - raise error + jsr L9E5B ; evaluate vertical distance + tfr d,x ; save vertical distance + puls u ; get horizontal distance + puls a ; get back first command character + cmpa #'+ ; was it + at start? + beq L9E56 ; brif +; treat values as positive + cmpa #'- ; was it -? + bne L9DFC ; brif not - treat it as absolute +L9E56 tfr u,d ; put horizontal distance somewhere useful + jmp L9DCB ; move draw position (relative) +L9E5B jsr L9B98 ; get input character +L9E5E cmpa #'+ ; leading +? + beq L9E69 ; brif so + cmpa #'- ; leading -? + beq L9E6A ; brif so - negative + jsr L9BE2 ; move pointer back one +L9E69 clra ; 0 for +, nonzero for - +L9E6A pshs a ; save sign flag + jsr L9CCB ; evaluate number + puls a ; get sign flag + tsta ; negative? + beq L9E78 ; brif not + clra ; zero extend and negate + negb + sbca #0 +L9E78 rts +; Table of sines and cosines for CIRCLE +L9E79 fdb 0x0000,0x0001 ; subarc 0 + fdb 0xfec5,0x1919 ; subarc 1 + fdb 0xfb16,0x31f2 ; subarc 2 + fdb 0xf4fb,0x4a51 ; subarc 3 + fdb 0xec84,0x61f9 ; subarc 4 + fdb 0xe1c7,0x78ae ; subarc 5 + fdb 0xd4dc,0x8e3b ; subarc 6 + fdb 0xc5e5,0xa269 ; subarc 7 + fdb 0xb506,0xb506 ; subarc 8 +; CIRCLE command +; The circle is drawn as a 64 sided polygon (64 LINE commands essentially) +CIRCLE cmpa #'@ ; is there an @ before coordinates? + bne L9EA3 ; brif not + jsr GETNCH ; eat the @ +L9EA3 jsr L9522 ; get max coordinates for screen + jsr L93B2 ; parse coordinates for circle centre + jsr L931D ; normalize the start coordinates + ldx ,u ; get horizontal coordinate + stx VCB ; save it + ldx 2,u ; get vertical coordinate + stx VCD ; saveit + jsr SYNCOMMA ; make sure we have a comma + jsr LB73D ; evaluate radius expression + ldu #VCF ; point to temp storage + stx ,u ; save radius + jsr L9320 ; normalize radius + lda #1 ; default to PSET + sta SETFLG + jsr L9581 ; evaluate the colour expression + ldx #0x100 ; height/width default value + jsr GETCCH ; is there a ratio? + beq L9EDF ; brif not + jsr SYNCOMMA ; make sure we have a comma + jsr LB141 ; evaluate the ratio + lda FP0EXP ; multiply ratio by 256 + adda #8 + sta FP0EXP + jsr LB740 ; evaluate ratio to X (fraction part in LSB) +L9EDF lda PMODE ; get graphics mode + bita #2 ; is it even? + beq L9EE9 ; brif so + tfr x,d ; double the ratio + leax d,x +L9EE9 stx VD1 ; save height/width ratio + ldb #1 ; set the SET flag to PSET + stb SETFLG + stb VD8 ; set first time flag (set to 0 after arc drawn) + jsr L9FE2 ; evaluate circle starting point (octant, subarc) + pshs b,a ; save startpoint + jsr L9FE2 ; evaluate circle end point (octant, subarc) + std VD9 ; save endp oint + puls a,b +L9EFD pshs b,a ; save current circle position + ldx HOREND ; move end coordinates to start coordinates + stx HORBEG + ldx VEREND + stx VERBEG + ldu #L9E79+2 ; point to sine/cosine table + anda #1 ; even octant? + beq L9F11 ; brif so + negb ; convert 0-7 to 8-1 for odd octants + addb #8 +L9F11 aslb ; four bytes per table entry + aslb + leau b,u ; point to correct table entry + pshs u ; save sine/cosine table entry pointer + jsr L9FA7 ; calculate horizontal offset + puls u ; get back table entry pointer + leau -2,u ; move to cosine entry + pshs x ; save horizontal offset + jsr L9FA7 ; calculate vertical offset + puls y ; put horizontal in Y + lda ,s ; get octant number + anda #3 ; is it 0 or 4? + beq L9F31 ; brif so + cmpa #3 ; is it 3 or 7? + beq L9F31 ; brif so + exg x,y ; swap horizontal and vertical +L9F31 stx HOREND ; save horizontal offset + tfr y,x ; put vertical offset in X + ldd VD1 ; get height/width ratio + jsr L9FB5 ; multiply vertical by h/w ratio + tfr y,d ; save the product to D + tsta ; did it overflow? + lbne LB44A ; brif so + stb VEREND ; save vertical coordinate MSB + tfr u,d ; get LSW of product + sta VEREND+1 ; save LSB of integer part (we have 8 bits of fraction in the ratio) + lda ,s ; get octant + cmpa #2 ; is it 0 or 1? + blo L9F5B ; brif so + cmpa #6 ; is it 6 or 7? + bhs L9F5B ; brif so + ldd VCB ; get horizontal centre + subd HOREND ; subtract horizontal displacement + bcc L9F68 ; brif we didn't overflow the screen + clra ; zero out coordinate if we overflowed the screen + clrb + bra L9F68 +L9F5B ldd VCB ; get horizontal coordinate of the centre + addd HOREND ; add displacement + bcs L9F66 ; brif overlod + cmpd VD3 ; larger than max horizontal coord? + blo L9F68 ; brif not +L9F66 ldd VD3 ; maximize the coordinate +L9F68 std HOREND ; save horizontal ending coordainte + lda ,s ; get octant + cmpa #4 ; is it 0-3? + blo L9F7A ; brif so + ldd VCD ; get vertical coordinate of centre + subd VEREND ; subtract displacement + bcc L9F87 ; brif we didn't overflow the screen + clra ; minimize to top of screen + clrb + bra L9F87 +L9F7A ldd VCD ; get vertical centre coordinate + addd VEREND ; add displacement + bcs L9F85 ; brif we overflowed the screen + cmpd VD5 ; did we go past max coordinate? + blo L9F87 ; brif not +L9F85 ldd VD5 ; maximize the coordinate +L9F87 std VEREND ; save end coordinate + tst VD8 ; check first time flag + bne L9F8F ; do not draw if first time through (it was setting start coord) + bsr L9FDF ; draw the line +L9F8F puls a,b ; get arc number and sub arc + lsr VD8 ; get first time flag value (and clear it!) + bcs L9F9A ; do not check for end point after drawing for first coordinate + cmpd VD9 ; at end point? + beq L9FA6 ; brif drawing finished +L9F9A incb ; bump arc counter + cmpb #8 ; done 8 arcs? + bne L9FA3 ; brif not + inca ; bump octant + clrb ; reset subarc number + anda #7 ; make sure octant number stays in 0-7 range +L9FA3 jmp L9EFD ; go do another arc +L9FA6 rts +L9FA7 ldx VCF ; get radius + ldd ,u ; get sine/cosine table entry + beq L9FB4 ; brif 0 - offset = radius + subd #1 ; adjust values to correct range + bsr L9FB5 ; multiply radius by sine/cosine + tfr y,x ; resturn result in X +L9FB4 rts +L9FB5 pshs u,y,x,b,a ; save registers and reserve temp space + clr 4,s ; reset overflow byte (YH) + lda 3,s ; calcuate B*XL + mul + std 6,s ; put in "U" + ldd 1,s ; calculate B*XH + mul + addb 6,s ; accumluate with previous product + adca #0 + std 5,s ; save in YL,UH + ldb ,s ; calculate A*XL + lda 3,s + mul + addd 5,s ; accumulate with previous partical product + std 5,s ; save in YL,UH + bcc L9FD4 ; brif no carry + inc 4,s ; bump YH for carry +L9FD4 lda ,s ; calculate A*XH + ldb 2,s + mul + addd 4,s ; accumulate with previous partial product + std 4,s ; save in Y (we can't have a carry here) + puls a,b,x,y,u,pc ; restore multiplicands and return results +L9FDF jmp L94A1 ; go draw a line +L9FE2 clrb ; default arc number (0) + jsr GETCCH ; is there something there for a value? + beq L9FF8 ; brif not + jsr SYNCOMMA ; evaluate , + expression + jsr LB141 + lda FP0EXP ; multiply by 64 + adda #6 + sta FP0EXP + jsr LB70E ; get integer value of circle fraction + andb #0x3f ; max value of 63 +L9FF8 tfr b,a ; save arc value in A to calculate octant + andb #7 ; calculate subarc + lsra ; calculate octant + lsra + lsra + rts +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; COLOR BASIC ROM area +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; 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 lda #0x3a ; restore MMU block in 0x4000-0x5fff block + sta MMUREG+2 + ldx #PIA1 ; point to PIA1 + ldd #0xff34 ; set up for initializing PIAs + 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 + lda #2 ; set RS232 to marking + sta ,x + lda #0xff + ldx #PIA0 ; point to PIA0 + clr 1,x ; set PIA0 DA to direction mode + clr 3,x ; set PIA0 DB to direction mode + clr ,x ; set PIA0 DA to input + sta 2,x ; set PIA0 DB to output + stb 1,x ; set PIA0 DA to direction mode + stb 3,x ; set PIA0 DB to direction mode + jmp LA072 ; continue initializing +LA05E jsr L8C2E ; map ROM pack + jmp 0xc000 ; transfer control to ROM pack +; Left over initialization code from Color Basic 1.2 follows + bitb 2,x ; check RAMSZ input + beq LA072 ; brif set for 4K RAMs + clr -2,x ; set strobe low + bitb 2,x ; check input + beq LA070 ; brif set for 64K rams + leau -2,u ; adjust pointer to set SAM for 16K RAMs +LA070 sta -3,u ; program SAM for either 16K or 64K 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 ldx #0x7fff ; set to of available RAM to just below the "ROM" area + bra LA093 + nop + nop + nop + nop + nop + nop + nop + nop + nop + nop +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" + jmp L8002 ; transfer control to ECB's initialization routine +LA0CE pshs b,x ; save registers + tst HRWIDTH ; is it VDG mode? + lbne ALINK24 ; brif not +LA0D6 jsr LA199 ; do a "cursor" + jsr KEYIN ; read a key + beq LA0D6 ; brif no key +LA0DE jmp LA1B9 ; return to mainline + fcb 0x72 ; left-over from code replacement above +LA0E2 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 CLS ; 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 L8C28 ; map cartridge + 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.2' + 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 +LA1B9 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 jmp KEYIN ; transfer control to actual keyboard scan + rts ;* this actually removes a check to see if any keys are actually down + rts ;* which is unfortunate because it makes programs run slower. + rts + rts + rts + rts + rts +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 +LA30E 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 +LA3C6 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. +LA429 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 SYNCOMMA ; 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 STRINOUT ; 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 SYNCOMMA ; 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 SYNCOMMA ; 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 +LA5C7 jsr GETCCH ; set flags on current character +LA5C9 beq LA5C4 ; brif nothing there - it's good + jmp LB277 ; raise SN error +; EOF function +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 SYNCOMMA ; 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 EVALEXPB ; 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 EVALEXPB ; 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 STRINOUT ; go display it +; Evaluate an expression to B, prefixed by a comma, and do FC error if 0 +LA93F jsr SYNCOMMA ; force a comma +LA942 jsr EVALEXPB ; 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 +LA9BB 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 +LAC60 abx ; offset to correct message + bsr LACA0 ; send a char from X + bsr LACA0 ; send another char from X +LAC65 ldx #LABE1-1 ; point to "ERROR" message +LAC68 jsr STRINOUT ; 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 STRINOUT ; 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 +LAC9D 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 +LACA8 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 +LAD3F clr OLDPTR ; reset "CONT" state + clr OLDPTR+1 +LAD43 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 +LADC4 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 +LADD4 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 +LADF4 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 SYNCOMMA ; 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 EVALEXPB ; 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 STRINOUT + 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 SYNCOMMA ; 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 SYNCOMMA ; 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 STRINOUT +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 +SYNCOMMA 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 SYNCOMMA ; 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 EVALEXPB ; 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 +LB2CE 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 SYNCOMMA ; 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 +LB35C 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 SYNCOMMA ; force a comma + bsr EVALEXPB ; 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 +EVALEXPB 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 SYNCOMMA ; make sure there's a comma + bra EVALEXPB ; 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 +LB7F9 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 +LB902 jsr LA554 ; move cursor to correct location +LB905 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 SYNCOMMA ; 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 +STRINOUT 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 STRINOUT ; 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 a copy of the interrupt vectors that live at the top of the ROM. It's not clear +; why these vectors have been modified since they are not actually used. + fdb INT.SWI3 ; SWI3 + fdb INT.SWI2 ; SWI2 + fdb INT.FIRQ ; FIRQ + fdb INT.IRQ ; IRQ + fdb INT.SWI ; SWI + fdb INT.NMI ; NMI + fdb L8C1B ; RESET +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Coco3 internal ROM, upper 32K +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; This is the initialization code specific to the Coco3. This handles copying the ROMs to RAM and adding various patches in. +; This sequence of code demonstrates clearly that the creators of the Coco3 additions were rushed and didn't have a clear +; understanding of the Coco3 hardware or how Color Basic works. There is evidence of last minute adjustments along with code +; that serves no purpose but which is still present. +; +; There is also a major bug. The F1 for burst phase invert enable is clearly supposed to be enabled for the HSCREEN graphics +; modes. However, the code that enables it actually patches the wrong byte in the graphics mode initializers. Instead of enabling +; the burst phase invert bit in FF98, it actually enables the FIRQ enable bit in FF90. +SC000 orcc #0x50 ; make sure interrupts are disabled + lds #0x5eff ; put the stack somewhere + lda #0x12 ; nuclear green colour + ldb #16 ; 16 palette registers + ldx #PALETREG ; point to palette registers +SC00D sta ,x+ ; set a palette register to green + decb ; done? + bne SC00D ; brif not + ldx #MMUREG ; point to MMU registers + leay MMUIMAGE,pcr ; point to MMU initializer + ldb #16 ; there are 16 MMU registers +SC01B lda ,y+ ; copy an MMU initializer + sta ,x+ + decb ; done all? + bne SC01B ; brif not + lda #COCO+MMUEN+MC3+MC2+MC1 ; enable coco compatible, mmu, SCS, FExx, and 32K internal + sta INIT0 + leax BEGMOVE,pcr ; point to start of relocated initialization code + ldy #0x4000 ; point to RAM address where it goes +SC02F ldd ,x++ ; copy four bytes + ldu ,x++ + std ,y++ + stu ,y++ + cmpx #ENDMOVE ; copied everything? + blo SC02F ; brif not + jmp 0x4000 ; transfer control to code in RAM +; The rest runs from RAM. This allows it to mess with the ROM mapping (for the ROM/RAM copy). Unfortunately, +; this clobbers an 8K memory block *before* it determines that it isn't going to copy ROM to RAM which is +; somewhat problematic for things that intercept a warm start. +BEGMOVE leas -1,s ; make a hole on the stack + nop ; space fillers; probably something removed at the eleventh hour + nop + nop + nop + nop + lda #0xff ; set GIME timer to maximum value and start it counting + sta V.TIMER + sta V.TIMER+1 + leax VIDIMAGE,pcr ; point to video mode initializer + ldy #VIDEOMOD ; point to video mode registers +SC056 lda ,x+ ; copy a byte + sta ,y+ + cmpy #MMUREG ; done? + bne SC056 ; brif not + ldx #PIA1 ; point to PIA1 + ldd #0xff34 ; set up for initializing PIAs + 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 + lda #2 ; set RS232 to marking + sta ,x + lda #0xff + ldx #PIA0 ; point to PIA0 + clr 1,x ; set PIA0 DA to direction mode + clr 3,x ; set PIA0 DB to direction mode + clr ,x ; set PIA0 DA to input + sta 2,x ; set PIA0 DB to output + stb 1,x ; set PIA0 DA to direction mode + stb 3,x ; set PIA0 DB to direction mode + ldb #12 ; there are 12 SAM bits to reset + ldu #SAMREG ; point to SAM register +SC091 sta ,u++ ; clear a bit + decb ; done all? + bne SC091 ; brif not + sta SAMREG+9 ; put VDG display at 0x400 + tfr b,dp ; set direct page to 0 + clr 2,x ; strobe all keyboard columns (pointless) + sta -3,u ; select RAM page 1 (also pointless) + ldx #PIA0 ; point to PIA0 (unneeded - already points there) + ldb #0xdf ; column strobe for F1 + stb 2,x ; strobe for F1 + lda ,x ; get row data + coma ; set nonzero if F1 down + anda #0x40 + sta ,s ; save F1 state for later + ldy #2 ; check for two keys +SC0B1 asrb ; shift strobe (why not just shift directly in the PIA?) + stb 2,x ; strobe new column + lda ,x ; get row data + coma ; set nonzero if CTRL or ALT is down + anda #0x40 + beq SC0C2 ; brif not - we don't have C-A-RESET + leay -1,y ; done both? + bne SC0B1 ; brif not + lbra SC1F0 ; go do easter egg picture if C-A-RESET +SC0C2 lda #COCO+MMUEN+MC3+MC1 ; turn off standard SCS (why?) + sta INIT0 +; This checks if we have a valid warm start routine. If there is one, we don't do a ROM/RAM copy. This and +; everything above could just as easily have been done from ROM. + lda INT.FLAG ; are the bounce vectors valid? + cmpa #0x55 + bne SC0F6 ; brif not - copy ROM to RAM + lda RSTFLG ; is the DP reset vector marked valid? + cmpa #0x55 + bne NOWARM ; brif not + ldx RSTVEC ; does the vector point to NOP? + lda ,x + cmpa #0x12 + lbeq SC18C ; brif so - don't do ROM/RAM copy +NOWARM clr MMUREG ; put bottom memory block in logical block 0 (replaces DP) + lda RSTFLG ; does this give us a valid reset vector? + cmpa #0x55 + bne SC0F1 ; brif not + ldx RSTVEC ; does this routine point to a NOP? + lda ,x + cmpa #0x12 + lbeq SC18C ; brif so - don't do ROM/RAM copy and keep modified memory map +SC0F1 lda #BLOCK7.0 ; restore memory map + sta MMUREG +SC0F6 ldx #DOSBAS ; point to the end of Color Basic + ldy #EXBAS ; point to start of Extended Basic + lbsr SC1AA ; copy them to RAM + leay PATCHTAB,pcr ; point to patch table + lda ,y+ ; get number of patches to be made +SC106 pshs a ; save patch counter + ldx ,y++ ; get address to patch + ldb ,y+ ; get number of bytes in the patch +SC10C lda ,y+ ; copy a byte + sta ,x+ + decb ; done all in this patch? + bne SC10C + puls a ; get back patch counter + deca ; done all patches? + bne SC106 ; brif not + clr TYCLR ; got back to ROM mode + lda #COCO+MMUEN+MC3 ; set up for 16K split mode + sta INIT0 + ldd DOSBAS ; is there a Disk Basic ROM signature? + cmpa #'D ; (note that this should just be CMPD) + bne SC137 + cmpb #'K + bne SC137 + ldx #SUPERVAR ; point to end of Disk Basic ROM + ldy #DOSBAS ; point to start of Disk Basic ROM + bsr SC1AA ; copy it to RAM + lbsr SC322 ; add patches to Disk Basic +SC137 clr TYCLR ; go back to ROM mode + lda #COCO+MMUEN+MC3+MC1 ; set 32K internal mocde + sta INIT0 + ldx #H.CRSLOC ; point to end of the Coco3 additions + ldy #SUPERVAR ; point to start of the Coco3 additions + bsr SC1AA ; copy it to RAM + lbsr SC1DE ; set up an easter egg + leay INTIMAGE,pcr ; point to bounce vector initializer + ldx #INT.FLAG ; point to bounce vectors + ldb #19 ; 19 bytes in bounce vectors + lbsr MOVE.XY ; initialize the bounce vectors + clr TYSET ; enable RAM mode (the ROM/RAM copy already did this) + tst ,s ; was F1 pressed? + beq SC180 ; brif not + ldx #IM.TEXT ; point to text mode initializers + ldb #3 ; there are three sets of them + leax 1,x ; move past the FF90 initializer +SC165 lda ,x ; get video mode initializer + ora #0x20 ; enable burst phase invert + sta ,x ; update initializer + leax 9,x ; move to next mode + decb ; done all of them? + bne SC165 ; brif not + ldb #2 ; two graphics mode initalizers + ldx #IM.GRAPH ; point to graphics mode initializers (should be +1; we're actually enabling GIME FIRQ) +SC175 lda ,x ; get initializer + ora #0x20 ; enable burst phase invert (or it would if X pointed to the right place) + sta ,x ; save modified initializer + leax 9,x ; move to next set + decb ; done all of them? + bne SC175 ; brif not +SC180 ldx #VIDRAM ; point to start of VDG text screen + lda #0x60 ; VDG space character +SC185 sta ,x+ ; blank a character + cmpx #VIDRAM+512 ; end of screen? + blo SC185 ; brif not +SC18C lda #COCO+MMUEN+MC3+MC2+MC1 ; turn the SCS back on + sta INIT0 + tst ,s ; F1? + beq SC19A ; brif not + lda #0x20 ; enable burst phase invert + sta VIDEOMOD +SC19A ldx #PALETREG ; point to palette registers + leay PALIMAGE,PCR ; point to palette initializer + ldb #16 ; do 16 palette registers + bsr MOVE.XY ; initialize palette + leas 1,s ; clean up stack (not much point since it will be reset anyway) + jmp RESVEC ; transfer control to the original Color Basic initialization routine +SC1AA stx 0x5f02 ; save end copy address + sts 0x5f00 ; save stack +SC1B1 clr TYCLR ; go to ROM mode + ldd ,y ; grab 8 bytes + ldx 2,y + ldu 4,y + lds 6,y + clr TYSET ; go to RAM mode + std ,y ; save the 8 bytes + stx 2,y + stu 4,y + sts 6,y + leay 8,y ; move pointer forward + cmpy 0x5f02 ; done yet? + blo SC1B1 ; brif not + lds 0x5f00 ; restore stack pointer + rts +MOVE.XY lda ,y+ ; copy a byte + sta ,x+ + decb ; done all? + bne MOVE.XY ; brif not + rts +SC1DE ldx #AUTHORMS ; point to author name easter egg + leay SC30D,pcr ; point to encoded names + ldb #21 ; 21 bytes in names +SC1E7 lda ,y+ ; get encoded byte + coma ; decode (wow. one's complement encoding.) + sta ,x+ ; put in copied ROM + decb ; done all? + bne SC1E7 ; brif not + rts +SC1F0 clra ; set up to mark things as invalid + sta INT.FLAG ; mark bounce vectors invalid + sta RSTFLG ; mark reset vector invalid + sta TYCLR ; go to ROM mode + ldb #9 ; foreground colour for image + stb PALETREG+10 + ldb #63 ; white background + stb PALETREG+11 + ldx #AUTHPIC ; point to author picture data + ldy #0xe00 ; put picture at 0xe00 in memory +SC20A ldd ,x++ ; copy four bytes + ldu ,x++ + std ,y++ + stu ,y++ + cmpx #AUTHPICe ; at end of picture data? + blo SC20A ; brif not + lda #0xf9 ; 256x192, CSS0 VDG mode + sta PIA1+2 + clra ; this instruction is useless + ldx #SAMREG ; point to SAM register + sta ,x ; set SAM address to 0xe00 and video mode to 256x192 + sta 3,x + sta 5,x + sta 7,x + sta 9,x + sta 11,x +WAITLOOP bra WAITLOOP ; freeze the system +VIDIMAGE fcb 0x00,0x00,0x00,0x00,0x0f,0xe0,0x00,0x00 +PALIMAGE fcb 18,36,11,7,63,31,9,38,0,18,0,63,0,18,0,38 +MMUIMAGE fcb BLOCK7.0,BLOCK7.1,BLOCK6.4,BLOCK7.3 + fcb BLOCK7.4,BLOCK7.5,BLOCK7.6,BLOCK7.7 + fcb BLOCK7.0,BLOCK6.0,BLOCK6.1,BLOCK6.2 + fcb BLOCK6.3,BLOCK7.5,BLOCK6.5,BLOCK7.7 +PATCHTAB fcb 27 ; 27 patches to install +; Patch #1: enable warm start routine after ROM/RAM copy +patch1 fdb XBWMST + fcb patch2-*-1 + nop +; Patch #2: intercept tokenization routine +patch2 fdb LB8D4 + fcb patch3-*-1 + jmp ALINK2 +; Patch #3: intercept detokenization routine +patch3 fdb LB7F3 + fcb patch4-*-1 + jmp ALINK3 +; Patch #4: intercept Extended Basic's command interpretation handler +patch4 fdb L8150 + fcb patch5-*-1 + jmp ALINK4 + nop +; Patch #5: intercept Extended Basic's function handler +patch5 fdb L816C + fcb patch6-*-1 + jmp ALINK5 + nop +; Patch #6 through patch #10 - extend &H and &O to allow 24 bit values +patch6 fdb L8834 + fcb patch7-*-1 + jmp ALINK6A + clr FPA0+1 + clr FPA0+2 + clr FPA0+3 + bra *-78 + clr FPA0 + bra *-47 + jmp ALINK6B +patch7 fdb L87EB + fcb patch8-*-1 + bra *+76 + nop + rts + ldx #FPA0+1 +patch8 fdb L880C + fcb patch9-*-1 + bra *+55 +patch9 fdb L8826 + fcb patch10-*-1 + bcs *+25 +patch10 fdb L87E7 + fcb patch11-*-1 + bne *+7 +; Patch #11 is needed because the above removed an RTS used by this routine +patch11 fdb L886A + fcb patch12-*-1 + bne *-124 +; Patch #12 - intercept signon message display +patch12 fdb L80B2 + fcb patch13-*-1 + jmp ALINK12 +; Patch #13 - remove one carriage return from signon message +patch13 fdb L80E8+82 + fcb patch14-*-1 + fcb 0 +; Patch #14 - extend Extended Basic's graphics initialization routine +patch14 fdb L9703 + fcb patch15-*-1 + jmp ALINK14 +; Patch #15 - intercept break check +patch15 fdb LADF0 + fcb patch16-*-1 + jmp ALINK15 + nop +; Patch #16 - intercept break check when handling "line input" +patch16 fdb LA3C2 + fcb patch17-*-1 + jmp ALINK16 + nop +; Patch #17 - cause INPUT to respond to ON BRK +patch17 fdb LB03C+1 + fcb patch18-*-1 + fdb ALINK17 +; Patch #18 - intercept ON command +patch18 fdb ON + fcb patch19-*-1 + jmp ALINK18 +; Patch #19 - add on extra stuff to end of NEW +patch19 fdb LAD3F + fcb patch20-*-1 + jmp ALINK19 + nop +; Patch #20 - intercept error handler +patch20 fdb LAC46 + fcb patch21-*-1 + jmp ALINK20 +; Patch #21 - intercept immediate mode loop +patch21 fdb LAC73 + fcb patch22-*-1 + jmp ALINK21 +; Patch #22 - intercept character to screen routine +patch22 fdb LA30A + fcb patch23-*-1 + jmp L8C37 +; Patch #23 - intercept CLS +patch23 fdb CLS + fcb patch24-*-1 + jmp L8C46 +; Patch #24 - intercept waiting for keypress with cursor routine +patch24 fdb LA1B1 + fcb patch25-*-1 + jmp LA0CE + nop + nop + nop + nop + nop +; Patch #25 - intercept PRINT @ +patch25 fdb LB902 + fcb patch26-*-1 + jmp ALINK25 +; Patch #26 - intercept conditional newline routine +patch26 fdb LB95C + fcb patch27-*-1 + jmp ALINK26 +; Patch #27 - intercept CLEAR handling in line input routine +patch27 fdb LA38D + fcb patch27e-*-1 + jmp ALINK27 +patch27e equ * +; Names of the authors in one's complemented ASCII +SC30D fcb 0xab,0xd1,0xb7,0x9e,0x8d,0x8d,0x96,0x8c + fcb 0xdf,0xd9,0xdf,0xab,0xd1,0xba,0x9e,0x8d + fcb 0x93,0x9a,0x8c,0xf2,0xff +SC322 lda DOSBAS+4 ; get MSB of DSKCON vector + cmpa #0xd6 ; is it 0xd6? + bne SC334 ; brif not - we have Disk Basic 1.1 + ldx #0xc0c6 ; point to patch address in Disk Basic 1.0 + leay SC355,pcr ; point to patch for Disk Basic 1.0 + ldb ,y+ ; get number of bytes to patch + bra SC349 ; go patch it +SC334 ldx #0xC8B4 ; point to Disk Basic 1.1 keyboard check (in the interpretation loop handler) + lda #0x12 ; NOP opcode + ldb #11 ; clobber 11 bytes (which check for a key down before calling the break check) +SC33B sta ,x+ ; put a NOP + decb ; done? + bne SC33B ; brif not + ldx #0xc0d9 ; point to the Disk Basic 1.1 patch address + leay SC351,pcr ; point to patch for Disk Basic 1.1 + ldb ,y+ ; get number of bytes in patch +SC349 lda ,y+ ; put a byte from the patch + sta ,x+ + decb ; done yet? + bne SC349 ; brif not + rts +; Copyright message patch for Disk Basic 1.1 +SC351 fcb SC355-*-1 + jmp ALINK29 +; Copyright message patch for Disk Basic 1.0 +SC355 fcb SC355e-*-1 + jmp ALINK28 +SC355e equ * +; This is the initializer for the bounce vector table. It sets up to transfer control to Color Basic's +; interrupt vectors at 0x100. These really should be JMP instead of LBRA, if only because JMP is faster. +INTIMAGE fcb 0x55 ; valid vector table flag + lbra (INTIMAGE+1)-(INT.JUMP)+SW3VEC ; SWI3 + lbra (INTIMAGE+1)-(INT.JUMP)+SW2VEC ; SWI2 + lbra (INTIMAGE+1)-(INT.JUMP)+FRQVEC ; FIRQ + lbra (INTIMAGE+1)-(INT.JUMP)+IRQVEC ; IRQ + lbra (INTIMAGE+1)-(INT.JUMP)+SWIVEC ; SWI + lbra (INTIMAGE+1)-(INT.JUMP)+NMIVEC ; NMI +ENDMOVE equ * +; Unused bytes + fcb 0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0x00,0x55,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0x00,0x18,0x00,0x0E,0x00 +; This is the "pmode 4" author picture easter egg +AUTHPIC fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF7,0xFF,0xFB,0xEE,0xEF,0xFB,0xFF,0xBB,0xFF,0xFF,0xFF,0xFB,0xFF,0xFF,0xBB + fcb 0xBB,0xBB,0xBF,0xBB,0xBB,0xFF,0xBF,0xFF,0xFE,0xEF,0xFF,0xFF,0xFF,0xEF,0x7F,0xFF + fcb 0xFF,0xF7,0xBB,0xFF,0xBB,0xBB,0xBF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xBB,0xBF,0xBB,0xFF,0xBB,0x7F,0xFF + fcb 0xFF,0xF6,0xEE,0xEE,0xEE,0xEE,0xEE,0xEF,0xFF,0xFE,0xFF,0xFE,0xEE,0xEE,0xFE,0xEE + fcb 0xEE,0xEE,0xEF,0xEE,0xEE,0xEE,0xEE,0xEE,0xFE,0xEE,0xEE,0xEE,0xEE,0xEE,0x7F,0xFF + fcb 0xFF,0xF3,0xBB,0xFF,0xBB,0xBB,0xBB,0xBB,0xBF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFB,0xBB,0xBB,0xBB,0xBB,0xBB,0x7F,0xFF + fcb 0xFF,0xF6,0xAA,0xAE,0xAA,0xAE,0xAA,0xEA,0xBB,0xBB,0xFB,0xFF,0xBB,0xFF,0xBF,0xBF + fcb 0xFF,0xFB,0xBF,0xBB,0xBB,0xBB,0xBB,0xBB,0xBA,0xEA,0xAA,0xEE,0xAE,0xEE,0x7F,0xFF + fcb 0xFF,0xF3,0xBB,0xBF,0xBB,0xBB,0xBB,0xBB,0xBF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFB,0xBB,0xBB,0xBB,0xBB,0xBB,0x7F,0xFF + fcb 0xFF,0xF6,0xEE,0xEE,0xEE,0xEE,0xEE,0xEE,0xEE,0xEE,0xEF,0xFE,0xEF,0xFF,0xFF,0xFF + fcb 0xFF,0xFE,0xEF,0xEE,0xEE,0xEE,0xEE,0xEE,0xEE,0xEE,0xEE,0xEE,0xEE,0xEF,0x7F,0xFF + fcb 0xFF,0xF7,0xBB,0xBB,0xBB,0xBB,0xBB,0xBB,0xBF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xBB,0xBB,0xBB,0xBB,0xBB,0x7F,0xFF + fcb 0xFF,0xF6,0xAA,0xEE,0xAA,0xAA,0xAA,0xEA,0xAB,0xBB,0xBB,0xFF,0xBB,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFB,0xBF,0xFF,0xFF,0xBB,0xBB,0xEA,0xAE,0xAA,0xAA,0xAF,0x7F,0xFF + fcb 0xFF,0xF7,0xBB,0xBB,0xBF,0xFF,0xFB,0xBB,0xBF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFB,0xBB,0xBB,0xBB,0xBB,0x7F,0xFF + fcb 0xFF,0xF6,0xEE,0xEE,0xEE,0xEF,0xEF,0xEE,0xEE,0xEF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xEE,0xEE,0xFF,0xEF,0xEE,0xEE,0xEF,0x7F,0xFF + fcb 0xFF,0xF7,0xBB,0xBB,0xBF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xBB,0xBB,0xBB,0x7F,0xFF + fcb 0xFF,0xF7,0xEA,0xAA,0xBB,0xBB,0xBB,0xBB,0xBB,0xFB,0xBB,0xBF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFB,0xFF,0xFB,0xFB,0xBB,0xBB,0xBA,0xAA,0xAA,0xEF,0x7F,0xFF + fcb 0xFF,0xF7,0xBB,0xBB,0xBF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFB,0xBB,0xBB,0xBB,0x7F,0xFF + fcb 0xFF,0xF6,0xEE,0xEE,0xEE,0xFE,0xEE,0xEE,0xEE,0xEE,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFE,0xEE,0xEF,0xFE,0xEE,0xEE,0xEE,0xEF,0x7F,0xFF + fcb 0xFF,0xF7,0xBB,0xBB,0xFB,0xBF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFE,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x0F,0xFF,0xFF,0xFF,0xFF,0xFF,0xFB,0xBB,0xBB,0xBB,0x7F,0xFF + fcb 0xFF,0xF6,0xEA,0xAB,0xAA,0xAB,0xBB,0xBB,0xBF,0xBF,0xFF,0xFF,0xFF,0x80,0x00,0x7F + fcb 0xFF,0xFF,0xC0,0x00,0x3F,0xFF,0xFF,0xBB,0xBB,0xBF,0xAA,0xAA,0xAA,0xEF,0x7F,0xFF + fcb 0xFF,0xF3,0xBB,0xBB,0xBB,0xBF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xBB,0xBB,0xBB,0xBF,0x7F,0xFF + fcb 0xFF,0xF6,0xEE,0xEE,0xEE,0xEF,0xEE,0xFF,0xFF,0xFF,0xEE,0xFF,0xFF,0x80,0x00,0x3F + fcb 0xFF,0xFF,0x80,0x00,0x3F,0xFF,0xFF,0xEE,0xFE,0xEE,0xEE,0xEE,0xEE,0xEF,0x7F,0xFF + fcb 0xFF,0xF3,0xBB,0xBB,0xBB,0xBF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xF0,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x07,0xFF,0xFF,0xFF,0xFF,0xFF,0xBB,0xBB,0xBB,0xBF,0x7F,0xFF + fcb 0xFF,0xF6,0xEE,0xAB,0xAE,0xEB,0xBB,0xBF,0xFB,0xFF,0xFF,0xFF,0xFF,0x80,0x00,0x1F + fcb 0xFF,0xFF,0x00,0x00,0x3F,0xFF,0xFF,0xFF,0xBB,0xBB,0xAA,0xAA,0xBE,0xAB,0x7F,0xFF + fcb 0xFF,0xF3,0xBB,0xBF,0xBB,0xBF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFB,0xFB,0xBB,0xBB,0xBF,0x7F,0xFF + fcb 0xFF,0xF6,0xEE,0xEE,0xEE,0xEE,0xEE,0xEF,0xFE,0xEF,0xFF,0xFF,0xFF,0x80,0x00,0x0F + fcb 0xFF,0xFE,0x00,0x00,0x3F,0xFF,0xFF,0xEF,0xEF,0xEE,0xEE,0xEE,0xEE,0xEF,0x7F,0xFF + fcb 0xFF,0xF3,0xBB,0xBF,0xFB,0xBF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xF0,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x03,0xFF,0xFF,0xFF,0xFF,0xFB,0xBF,0xFF,0xBB,0xBF,0x7F,0xFF + fcb 0xFF,0xF6,0xEA,0xAB,0xBA,0xAB,0xBB,0xFB,0xFF,0xBF,0xFF,0xFF,0xFF,0x80,0x00,0x07 + fcb 0xFF,0xFC,0x00,0x00,0x3F,0xFF,0xFF,0xFF,0xFB,0xAA,0xFF,0xFE,0xEA,0xAB,0x7F,0xFF + fcb 0xFF,0xF3,0xBB,0xBF,0xFB,0xBF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xBB,0xBF,0xFF,0xBB,0xBF,0x7F,0xFF + fcb 0xFF,0xF6,0xEE,0xEE,0xFF,0xFE,0xEE,0xEE,0xFF,0xFF,0xFF,0xFF,0xFF,0x80,0x00,0x03 + fcb 0xFF,0xF8,0x00,0x00,0x3F,0xFF,0xFF,0xFE,0xEE,0xEE,0xFF,0xFE,0xEE,0xEF,0x7F,0xFF + fcb 0xFF,0xF7,0xBB,0xBF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xF0,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x03,0xFF,0xFF,0xFF,0xFF,0xBB,0xBF,0xFF,0xBB,0xFF,0x7F,0xFF + fcb 0xFF,0xF7,0xAA,0xFB,0xBB,0xBB,0xBF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x80,0x00,0x01 + fcb 0xFF,0xF0,0x00,0x00,0x3F,0xFF,0xFF,0xBB,0xBB,0xAE,0xBB,0xBE,0xAF,0xBB,0x7F,0xFF + fcb 0xFF,0xF7,0xBB,0xBF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xBB,0xFF,0xFF,0xBB,0xFF,0x7F,0xFF + fcb 0xFF,0xF6,0xEE,0xEE,0xFF,0xFF,0xFF,0xFF,0xFE,0xFF,0xFF,0xFF,0xFF,0x80,0x08,0x00 + fcb 0xFF,0xE0,0x02,0x00,0x3F,0xFF,0xFF,0xFE,0xEF,0xEE,0xFF,0xEE,0xEF,0xEF,0x7F,0xFF + fcb 0xFF,0xF7,0xBB,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xF0,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x03,0xFF,0xFF,0xFF,0xFF,0xFB,0xFF,0xFF,0xBB,0xFF,0x7F,0xFF + fcb 0xFF,0xF7,0xAA,0xBB,0xBB,0xFB,0xBB,0xFF,0xBF,0xFF,0xFF,0xFF,0xFF,0x80,0x0C,0x00 + fcb 0x7F,0xC0,0x06,0x00,0x3F,0xFF,0xFF,0xFF,0xBB,0xFF,0xFF,0xBF,0xEB,0xBB,0x7F,0xFF + fcb 0xFF,0xF7,0xBB,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x7F,0xFF + fcb 0xFF,0xF6,0xEE,0xEF,0xFF,0xEF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x80,0x0E,0x00 + fcb 0x3F,0x80,0x0E,0x00,0x3F,0xFF,0xFF,0xFE,0xFF,0xFF,0xFE,0xEE,0xEE,0xFF,0x7F,0xFF + fcb 0xFF,0xF7,0xBB,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xF0,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x03,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x7F,0xFF + fcb 0xFF,0xF3,0xEA,0xBB,0xBF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x80,0x0F,0x00 + fcb 0x1F,0x00,0x1E,0x00,0x3F,0xFF,0xFF,0xFF,0xBF,0xFF,0xFF,0xFF,0xFF,0xBF,0x7F,0xFF + fcb 0xFF,0xF7,0xBB,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x7F,0xFF + fcb 0xFF,0xF7,0xEE,0xEE,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x80,0x0F,0x80 + fcb 0x0E,0x00,0x3E,0x00,0x3F,0xFF,0xFF,0xEE,0xFF,0xFF,0xFF,0xFE,0xEF,0xEF,0x7F,0xFF + fcb 0xFF,0xF7,0xBB,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xF0,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x03,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xBF,0x7F,0xFF + fcb 0xFF,0xF6,0xEA,0xBB,0xBB,0xBF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x80,0x0F,0xC0 + fcb 0x00,0x00,0x7E,0x00,0x3F,0xFF,0xFF,0xBF,0xFF,0xFF,0xFF,0xFF,0xBA,0xEF,0x7F,0xFF + fcb 0xFF,0xF7,0xBB,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0x00,0x1F,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xBB,0x7F,0xFF + fcb 0xFF,0xF6,0xEE,0xEE,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x80,0x0F,0xE0 + fcb 0x00,0x00,0xFE,0x00,0x3F,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFE,0xFE,0xEF,0x7F,0xFF + fcb 0xFF,0xF7,0xBB,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xF0,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x03,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xBB,0x7F,0xFF + fcb 0xFF,0xF6,0xEB,0xBF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x80,0x0F,0xC0 + fcb 0x00,0x00,0x3E,0x00,0x3F,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFE,0xEB,0x7F,0xFF + fcb 0xFF,0xF7,0xBB,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00 + fcb 0x00,0x00,0x1F,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xBA,0x7F,0xFF + fcb 0xFF,0xF6,0xEE,0xEF,0xFF,0xFF,0xFF,0xC0,0x1F,0xFF,0xFF,0xFF,0xFF,0x80,0x0C,0x00 + fcb 0x00,0x00,0x1E,0x00,0x3F,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xEE,0xEB,0x7F,0xFF + fcb 0xFF,0xF7,0xBB,0xFF,0xFF,0xFF,0xFC,0x00,0x0F,0xFF,0xFF,0xFF,0xF0,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x03,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFE,0xAA,0x7F,0xFF + fcb 0xFF,0xF6,0xAB,0xBB,0xFF,0xFF,0x00,0x00,0x03,0xFF,0xFF,0xFF,0xFF,0x80,0x0C,0x00 + fcb 0x00,0x00,0x06,0x00,0x3F,0xFF,0xFF,0xFF,0xFF,0xFF,0x79,0x9F,0xFB,0xAB,0x7F,0xFF + fcb 0xFF,0xF7,0xBB,0xFF,0xFF,0xF8,0x00,0x00,0x01,0xFF,0xFF,0xFF,0xFF,0xFF,0xF0,0x00 + fcb 0x00,0x38,0x03,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xF0,0x00,0x03,0xFE,0xEE,0x7F,0xFF + fcb 0xFF,0xF6,0xEF,0xFF,0xFF,0xE0,0x00,0x00,0x00,0x4F,0xFF,0xFF,0xFF,0x80,0x00,0x00 + fcb 0x01,0x7C,0x00,0x00,0x3F,0xFF,0xFF,0xFF,0xFF,0x80,0x00,0x00,0xFA,0xBB,0x7F,0xFF + fcb 0xFF,0xF7,0xFF,0xFF,0xFF,0xC0,0x00,0x00,0x00,0x01,0xFF,0xFF,0xF0,0x00,0x00,0x00 + fcb 0x03,0xFE,0x00,0x00,0x03,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x7E,0xEE,0x7F,0xFF + fcb 0xFF,0xF3,0xBB,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0x80,0x00,0x00 + fcb 0x0F,0xFF,0x00,0x00,0x3F,0xFF,0xFF,0xFF,0xFC,0x00,0x00,0x00,0x3B,0xBB,0x7F,0xFF + fcb 0xFF,0xF7,0xFF,0xFF,0xFE,0x00,0x00,0x00,0x00,0x00,0x7F,0xFF,0xFF,0xFF,0x00,0x00 + fcb 0x2F,0xFF,0x00,0x7F,0xFF,0xFF,0xFF,0xFF,0xF0,0x00,0x00,0x00,0x0E,0xEE,0x7F,0xFF + fcb 0xFF,0xF6,0xFF,0xFF,0xFC,0x00,0x00,0x00,0x00,0x00,0x3F,0xFF,0xFF,0x80,0x00,0x01 + fcb 0xFF,0xFF,0x80,0x00,0x3F,0xFF,0xFF,0xFF,0xE0,0x00,0x00,0x00,0x07,0xBB,0x7F,0xFF + fcb 0xFF,0xF7,0xFF,0xFF,0xF8,0x00,0x00,0x00,0x00,0x00,0x3F,0xFF,0xF0,0x00,0x00,0x03 + fcb 0xFF,0xFF,0x40,0x00,0x03,0xFF,0xFF,0xFF,0xC0,0x00,0x00,0x00,0x03,0xEE,0x7F,0xFF + fcb 0xFF,0xF3,0xBB,0xFF,0xF0,0x00,0x00,0x00,0x01,0x00,0x1F,0xFF,0xFF,0x80,0x01,0x07 + fcb 0xFF,0xFF,0xA0,0x00,0x3F,0xFF,0xFF,0xFF,0x80,0x00,0x00,0x00,0x01,0xBB,0x7F,0xFF + fcb 0xFF,0xF7,0xFF,0xFF,0xE0,0x00,0x00,0x00,0x01,0x80,0x1F,0xFF,0xFF,0xFE,0x0E,0x2F + fcb 0xFF,0xFF,0xC0,0x1F,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0xEE,0x7F,0xFF + fcb 0xFF,0xF6,0xFF,0xFF,0xE0,0x00,0x00,0x00,0x65,0xE0,0x0F,0xFF,0xFF,0x80,0x0C,0x1F + fcb 0xFF,0xFF,0xE0,0x00,0x3F,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x3B,0x7F,0xFF + fcb 0xFF,0xF7,0xFF,0xFF,0xC0,0x00,0x00,0x0B,0xFF,0xF0,0x0F,0xFF,0xFC,0x00,0x18,0x0F + fcb 0xF8,0x00,0x60,0x00,0x07,0xFF,0xFF,0xFE,0x00,0x00,0x00,0x00,0x00,0x0E,0x7F,0xFF + fcb 0xFF,0xF3,0xBB,0xFF,0xC0,0x00,0x01,0xFF,0xFF,0xF8,0x0F,0xFF,0xFF,0x80,0x00,0x01 + fcb 0xF8,0x00,0x20,0x00,0x3F,0xFF,0xFF,0xFE,0x00,0x00,0x00,0x00,0x00,0x1B,0x7F,0xFF + fcb 0xFF,0xF7,0xFF,0xFF,0x80,0x00,0x03,0xFF,0xFF,0xFC,0x0F,0xFF,0xFF,0xFC,0x03,0x03 + fcb 0xFF,0x7F,0xF0,0x03,0xFF,0xFF,0xFF,0xFC,0x00,0x00,0x00,0x00,0x00,0x0E,0x7F,0xFF + fcb 0xFF,0xF7,0xFE,0xFF,0x80,0x01,0x5D,0xFF,0xFF,0xFC,0x0F,0xFF,0xFF,0xC0,0x07,0xF1 + fcb 0xFC,0x07,0xFC,0x00,0x3F,0xFF,0xFF,0xFC,0x00,0x00,0x00,0x00,0x00,0x03,0x7F,0xFF + fcb 0xFF,0xF7,0xBF,0xFF,0x00,0x02,0xEF,0xFF,0xFF,0xFC,0x0F,0xFF,0xFF,0x00,0x0E,0x00 + fcb 0x7C,0x00,0xF4,0x00,0x0C,0x7F,0xFF,0xF8,0x00,0x00,0x00,0x00,0x00,0x0E,0x7F,0xFF + fcb 0xFF,0xF2,0xAB,0xFF,0x00,0x05,0xFF,0xFF,0xFF,0xFE,0x0F,0xFF,0xFF,0xF8,0x1C,0x00 + fcb 0xFC,0x01,0xF8,0x01,0xFB,0xBF,0xFF,0xF8,0x00,0x00,0x0F,0xE1,0x80,0x0B,0x7F,0xFF + fcb 0xFF,0xF7,0xBF,0xFF,0x00,0x03,0xFF,0xFF,0xFF,0xFE,0x0F,0xFF,0xFF,0xF8,0x1F,0xC0 + fcb 0xFE,0x3F,0xFC,0x01,0xF6,0xDF,0xFF,0xF8,0x00,0x3F,0xFF,0xFF,0x80,0x0E,0x7F,0xFF + fcb 0xFF,0xF6,0xEE,0xEE,0x00,0x07,0xFF,0xFF,0xFF,0xFE,0x0F,0xFE,0xFF,0xFC,0x1F,0xF1 + fcb 0xFF,0x9F,0xF8,0x37,0xF5,0xDF,0xFF,0xF8,0x00,0xFF,0xFF,0xFF,0x80,0x0B,0x7F,0xFF + fcb 0xFF,0xF7,0xBF,0xFF,0x00,0x07,0xFF,0xFF,0xFF,0xFF,0x07,0xFF,0xFF,0xF8,0x0F,0xEF + fcb 0x7F,0xFF,0xFC,0x03,0xF6,0xDF,0xFF,0xF8,0x7F,0xFF,0xFF,0xFF,0x80,0x06,0x7F,0xFF + fcb 0xFF,0xF6,0xFF,0xBF,0x00,0x03,0xFF,0xFF,0xFF,0xFF,0x07,0xFB,0xBB,0xFD,0xDF,0xFF + fcb 0xEF,0xFF,0xF9,0x7F,0xFB,0xBF,0xFF,0xFC,0x7F,0xFF,0xFF,0xFF,0xC0,0x0B,0x7F,0xFF + fcb 0xFF,0xF7,0xBF,0xFE,0x00,0x03,0xFF,0xFF,0xFF,0xF8,0x07,0xFF,0xFF,0xFF,0x9F,0xFF + fcb 0xFF,0xFF,0xFF,0xBF,0xFC,0x7F,0xFF,0xFC,0x75,0x0F,0xFF,0xCF,0xC0,0x0E,0x7F,0xFF + fcb 0xFF,0xF6,0xFF,0xFE,0x00,0x07,0xF5,0x47,0xFF,0xE0,0x07,0xFF,0xEF,0xFF,0xCF,0xFD + fcb 0xFF,0xFF,0xFF,0x3F,0xFF,0xFF,0xFF,0xFC,0x00,0x00,0xE0,0x07,0xC0,0x0F,0x7F,0xFF + fcb 0xFF,0xF7,0xBF,0xFF,0x00,0x0F,0xF8,0x07,0xFF,0xDC,0x07,0xFF,0xFF,0xFF,0xCF,0xFB + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFC,0x00,0x00,0x00,0x03,0xE0,0x0D,0x7F,0xFF + fcb 0xFF,0xF6,0xFF,0xFE,0x00,0x1F,0xD1,0x1F,0xFF,0xEF,0x07,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xF1,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFE,0x00,0x00,0x00,0x7B,0xF0,0x0B,0x7F,0xFF + fcb 0xFF,0xF3,0xBF,0xFE,0x00,0x1F,0xFF,0xEF,0xFE,0x81,0x07,0xFF,0xFF,0xFF,0x7F,0xF8 + fcb 0x40,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFE,0x60,0x01,0xFC,0x1D,0xF0,0x0D,0x7F,0xFF + fcb 0xFF,0xF6,0xEE,0xFF,0x00,0x1F,0xFF,0x01,0xFE,0x01,0x87,0xFE,0xEE,0xFF,0xFF,0xF0 + fcb 0x00,0x1F,0xFF,0xFF,0xFF,0xFF,0xFF,0xFE,0xE0,0x03,0xF0,0x67,0xF0,0x17,0x7F,0xFF + fcb 0xFF,0xF3,0xBF,0xFE,0x00,0x1F,0xF8,0x01,0xFC,0x03,0x87,0xFF,0xFF,0xFF,0xFF,0xC0 + fcb 0x00,0x0F,0xFC,0x3F,0xFF,0xFF,0xFF,0xFF,0xC0,0x03,0xF0,0x33,0xF0,0x5F,0x7F,0xFF + fcb 0xFF,0xF6,0xAF,0xFE,0x00,0x1F,0xFF,0xF0,0xFE,0x0F,0x87,0xFF,0xBF,0xFF,0xFF,0x80 + fcb 0xFF,0x07,0xF8,0x3F,0xFF,0xFF,0xFF,0xFF,0xFF,0x03,0xFA,0xFF,0xF1,0xBB,0x7F,0xFF + fcb 0xFF,0xF3,0xBF,0xBF,0x00,0x1F,0xFF,0xFE,0xFE,0x9B,0x87,0xFF,0xFF,0xFF,0xFF,0xBD + fcb 0x80,0xF3,0xF8,0x3F,0xFF,0xFF,0xFF,0xFF,0xFF,0x17,0xFF,0xFF,0xF4,0xEE,0x7F,0xFF + fcb 0xFF,0xF6,0xEE,0xFF,0x00,0x1F,0xFF,0xFF,0xFF,0x03,0x87,0xEF,0xEE,0xEF,0xFF,0x00 + fcb 0x00,0x07,0xF8,0x3F,0xFF,0xFF,0xFF,0xFF,0xFF,0x77,0xFF,0xFF,0xFE,0xBB,0x7F,0xFF + fcb 0xFF,0xF3,0xBF,0xBF,0x00,0x0F,0xFF,0xEF,0xF8,0x83,0x87,0xFF,0xFF,0xFF,0xFF,0xBE + fcb 0xBF,0xFF,0xF8,0x7F,0xFF,0xFF,0xFF,0xFF,0xFD,0xB3,0xFF,0xFF,0xFD,0xEE,0x7F,0xFF + fcb 0xFF,0xF6,0xEE,0xEF,0x00,0x0F,0xFF,0xF8,0x7F,0xF7,0x8F,0xFF,0xFB,0xBF,0xFF,0xFF + fcb 0xFF,0xF7,0xFC,0xFF,0xBF,0xFF,0xFF,0xFF,0xFF,0x07,0xFF,0xFF,0xFF,0xBB,0x7F,0xFF + fcb 0xFF,0xF3,0xBB,0xBB,0x00,0x0F,0xFF,0xF3,0x7F,0x0F,0x8F,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xBF,0xE3,0xFC,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x07,0xFF,0xFF,0xFF,0xEE,0x7F,0xFF + fcb 0xFF,0xF6,0xEE,0xEF,0x00,0x0F,0xFE,0xF7,0xFF,0xCF,0x8E,0xFF,0xFF,0xEF,0xFF,0xFF + fcb 0x17,0xF7,0xFD,0xEF,0xEF,0xFE,0xFF,0xFF,0xFF,0x9F,0xFF,0xFF,0xFF,0xBB,0x7F,0xFF + fcb 0xFF,0xF3,0xBB,0xBB,0x00,0x07,0xFF,0xFE,0xFF,0xC1,0x9F,0xFF,0xFF,0xFF,0xFF,0xFE + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x07,0xF7,0xFF,0xFE,0xEE,0x7F,0xFF + fcb 0xFF,0xF6,0xEE,0xEE,0x00,0x03,0xFF,0xC4,0x1C,0x03,0x9B,0xFB,0xAF,0xBF,0xFF,0xFF + fcb 0xFF,0xFF,0xFE,0xFB,0xFB,0xBB,0xFF,0xBF,0xFE,0x02,0xAB,0xFF,0xF8,0xFB,0x7F,0xFF + fcb 0xFF,0xF3,0xBF,0xBA,0x04,0x03,0xFA,0x00,0x00,0x01,0x9F,0xFF,0xBB,0xFF,0xFB,0xFF + fcb 0xFF,0xFF,0xFB,0xBF,0xFF,0xFB,0xFE,0xEF,0xFC,0x00,0x05,0xFF,0xF9,0xEE,0x7F,0xFF + fcb 0xFF,0xF6,0xEE,0xEC,0x06,0x01,0xFC,0xA2,0x00,0x03,0x9F,0xEE,0xEE,0xEF,0xFE,0xFF + fcb 0xFF,0xFF,0xFE,0xFF,0xFE,0xEE,0xEF,0xBF,0xFE,0x00,0x00,0x3F,0xFB,0xBB,0x7F,0xFF + fcb 0xFF,0xF3,0xBB,0xB0,0x00,0x01,0xFA,0x10,0x00,0x03,0x9F,0xFB,0xBB,0xFF,0xFB,0xFF + fcb 0xFF,0xFF,0xFB,0xBF,0xFF,0xFB,0xBE,0xEF,0xFC,0x0F,0x80,0x1F,0xF6,0xEE,0x7F,0xFF + fcb 0xFF,0xF6,0xEE,0xEE,0x00,0x00,0x68,0x5F,0xFE,0x03,0x1B,0xAE,0xAE,0xFB,0xEE,0xFD + fcb 0xFF,0xFF,0xFE,0xAB,0xBB,0xEA,0xFF,0xBF,0xF8,0x0B,0xFC,0x1F,0xFF,0xBB,0x7F,0xFF + fcb 0xFF,0xF3,0xBB,0xBA,0x00,0x00,0x7B,0x0F,0xFE,0x00,0x1F,0xBB,0xBB,0xFF,0xFB,0xFF + fcb 0xFF,0xFF,0xFB,0xBB,0xFF,0xBB,0xBE,0xEF,0xFC,0x07,0xFC,0x5F,0xF6,0xEE,0x7F,0xFF + fcb 0xFF,0xF6,0xEE,0xEE,0x00,0x00,0x14,0x40,0x3C,0x00,0x0E,0xEE,0xEE,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFE,0xEE,0xEE,0xEE,0xEF,0xBF,0xFE,0x00,0x61,0xFF,0xFF,0xBB,0x7F,0xFF + fcb 0xFF,0xF3,0xBB,0x80,0x00,0x00,0x00,0x7E,0x00,0x00,0x3F,0xBB,0xFF,0xFF,0xBF,0xFF + fcb 0xFF,0xFF,0xFF,0xBB,0xFF,0xBB,0xBE,0xEF,0xFF,0xE0,0x07,0xFF,0xFF,0xEE,0x7F,0xFF + fcb 0xFF,0xF6,0xEE,0x00,0x00,0x00,0x00,0x3F,0xEE,0x80,0x2E,0xAB,0xBF,0xBE,0xFC,0xFF + fcb 0xFF,0xFF,0xFE,0xEB,0xBB,0xAA,0xBB,0xBF,0xEF,0xFA,0xFF,0xFF,0xF8,0x0B,0x7F,0xFF + fcb 0xFF,0xF3,0xBA,0x00,0x00,0xC0,0x00,0x0F,0xFE,0x00,0x3B,0xBF,0xFF,0xFB,0xB1,0xFF + fcb 0xFF,0xFF,0xF3,0xBB,0xFF,0xBB,0xAE,0xEF,0xBF,0xD9,0x7F,0xFF,0xF8,0x02,0x7F,0xFF + fcb 0xFF,0xF6,0xEC,0x00,0x00,0xE0,0x00,0x00,0x00,0x00,0xEE,0xEE,0xEF,0xEE,0xE1,0xFF + fcb 0xFF,0xFF,0xF0,0xEE,0xEE,0xEE,0xEB,0xBF,0xEF,0x8E,0x3F,0xFF,0xF8,0x00,0x7F,0xFF + fcb 0xFF,0xF3,0xBA,0x00,0x00,0xF0,0x00,0x00,0x00,0x00,0xBB,0xBB,0xBF,0xBB,0xB1,0xFF + fcb 0xFF,0xFF,0xE0,0x3B,0xFF,0xBB,0xEE,0xFF,0xBB,0x00,0x5F,0xFF,0xF8,0x00,0x7F,0xFF + fcb 0xFF,0xF6,0xE0,0x04,0x00,0x78,0x00,0x00,0x00,0x01,0xEE,0xAA,0xAE,0xEA,0xC0,0x7F + fcb 0xFF,0xFF,0x80,0x0B,0xFF,0xEF,0xAB,0xFF,0xEF,0xC2,0x3F,0xFF,0xFF,0xE0,0x7F,0xFF + fcb 0xFF,0xF3,0x80,0x00,0x00,0x7C,0x00,0x00,0x00,0x00,0x3B,0xBB,0xBB,0xBB,0x00,0x3F + fcb 0xFF,0xFF,0x00,0x03,0xFF,0xFE,0xEE,0xEF,0xBB,0xC0,0x7F,0xFF,0xFE,0xF8,0x7F,0xFF + fcb 0xFF,0xF6,0x60,0xC0,0x00,0x7F,0x00,0x00,0x00,0x00,0x2E,0xEE,0xEE,0xEC,0x00,0x01 + fcb 0x3F,0xFC,0x00,0x00,0x6E,0xEF,0xFF,0xFB,0xEE,0xE2,0x3F,0xFF,0xFE,0x78,0x7F,0xFF + fcb 0xFF,0xF0,0x98,0x60,0x00,0x3F,0x80,0x00,0x00,0x00,0x03,0xBB,0xBB,0xB8,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x01,0xBB,0xBB,0xBA,0xBB,0x5F,0x9F,0xFF,0xFC,0xF8,0x7F,0xFF + fcb 0xFF,0xF6,0x00,0x30,0x00,0x0F,0xC0,0x00,0x00,0x00,0x00,0x6A,0xEE,0xA0,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFA,0xEE,0x83,0xFF,0xFF,0xFC,0xF8,0x7F,0xFF + fcb 0xFF,0xF4,0x00,0x00,0x00,0x07,0xE0,0x00,0x00,0x00,0x05,0x13,0xBB,0x80,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00,0x2E,0xEE,0xEA,0x9B,0xA3,0xFF,0xFF,0xFD,0xF0,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x01,0xF0,0x00,0x00,0x00,0x00,0x0E,0xEE,0x80,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00,0x2F,0xFE,0xAA,0x0E,0xED,0xFF,0xFF,0xF9,0xF0,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x78,0x00,0x00,0x00,0x00,0x03,0xBB,0x80,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00,0x0A,0xBA,0xA8,0x0B,0xFB,0x7F,0xFF,0xF3,0xF0,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x3C,0x00,0x00,0x00,0x00,0x02,0x8A,0x80,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00,0x02,0xFE,0xA0,0x06,0xFE,0xFF,0xFF,0x07,0xF0,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x1E,0x00,0x00,0x00,0x00,0x07,0x03,0x80,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00,0x02,0xAA,0x80,0x07,0xF9,0xFF,0xFC,0x07,0xF4,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x0F,0x14,0x0E,0x00,0x00,0x02,0x80,0x80,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0xAA,0x80,0xBF,0xFF,0xBF,0xF0,0x0F,0xF6,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x03,0xFF,0xFC,0x00,0x00,0x03,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0xEA,0x0F,0xFE,0x7C,0x77,0x80,0x1F,0xF6,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x01,0xFF,0xF8,0x00,0x00,0x03,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x28,0x7F,0xFC,0xFE,0x80,0x00,0x1F,0xF7,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0xFF,0xF0,0x00,0x00,0x03,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x20,0x37,0x3C,0xFE,0xC0,0x00,0xBF,0xF7,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x07,0x7F,0xE0,0x00,0x00,0xF3,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x3F,0x3E,0xFF,0x80,0x01,0xFF,0xF7,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0xA3,0xFF,0xC0,0x00,0x00,0x63,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x3F,0xFD,0xEE,0x80,0x07,0xFF,0xF7,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x63,0xFF,0xC0,0x00,0x00,0x73,0x00,0x00,0x00,0x00 + fcb 0xFF,0x00,0x00,0x00,0x00,0x00,0x08,0x1F,0x78,0xF7,0xE8,0x9F,0xFF,0xFC,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x77,0xBF,0x80,0x00,0x00,0x33,0x00,0x00,0x00,0x3F + fcb 0xBB,0xE0,0x00,0x00,0x00,0x00,0x00,0x1F,0xF8,0x3B,0x55,0x7F,0x80,0x70,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x01,0xFF,0x00,0x00,0x00,0x3B,0x00,0x00,0x00,0xFF + fcb 0x3B,0xFC,0x00,0x00,0x00,0x00,0x00,0x1F,0xFF,0x1D,0x8E,0xE7,0x82,0xF8,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0xFF,0x00,0x00,0x00,0x30,0x00,0x00,0x01,0xFE + fcb 0xF9,0x9F,0x00,0x00,0x00,0x00,0x00,0x0F,0xFF,0xC1,0x17,0xFF,0xFF,0xC0,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x0E,0x00,0x00,0x00,0x18,0x00,0x00,0x00,0xF8 + fcb 0xFF,0x3F,0xE0,0x00,0x04,0x00,0x00,0x0F,0xBF,0xC2,0xEF,0xFF,0xFF,0x80,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x06,0x00,0x00,0x00,0x1C,0x00,0x00,0x08,0xFB + fcb 0xFF,0x37,0xE0,0x00,0x00,0x00,0x00,0x0F,0xBF,0xC1,0x1F,0xFF,0xFF,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x0E,0x00,0x00,0x00,0x00,0x00,0x00,0x0E,0x00,0x00,0x1D,0x07 + fcb 0xFF,0xE3,0x68,0x00,0x00,0x00,0x00,0x07,0x7F,0xC7,0x3F,0xFF,0xFE,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x1C,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x3F + fcb 0xFF,0xFB,0xF6,0x00,0x00,0x00,0x00,0x07,0x7F,0xE1,0x7F,0xFF,0xFC,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x0E,0x00,0x00,0x00,0x00,0x00,0x01,0xC6,0x7F + fcb 0xFF,0xFF,0xE8,0x00,0x00,0x00,0x00,0x07,0x0F,0xF3,0x8F,0x97,0xFC,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x01,0xB1,0xEF + fcb 0xFF,0xEF,0xB7,0x00,0x00,0x00,0x00,0x07,0x83,0xE1,0xC6,0x00,0x78,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x21,0xDF + fcb 0xFF,0xD1,0xA2,0x00,0x00,0x40,0x00,0x03,0x00,0xF1,0xFF,0x14,0x20,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x3E,0xFF + fcb 0xFF,0xFF,0xDF,0x00,0x00,0x00,0x00,0x03,0x06,0x70,0x7C,0x00,0xC0,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x0F,0xFF + fcb 0xFF,0xFF,0xE7,0xE0,0x00,0x00,0x00,0x03,0x87,0xF1,0xF8,0x03,0x80,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x1E,0xAF + fcb 0xFF,0xFF,0xF7,0x00,0x00,0x00,0x00,0x03,0x8F,0xFB,0xF8,0x20,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x1F,0xBF + fcb 0xFF,0xFF,0xBF,0xE0,0x00,0x00,0x00,0xF3,0x8D,0xFF,0xF8,0x5F,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x1E,0xFF + fcb 0xFF,0xFF,0x4F,0xF0,0x00,0x00,0x01,0xE3,0x87,0xFF,0xFC,0x6E,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x0D,0xF7 + fcb 0xBF,0xFF,0xEF,0xE8,0x00,0x00,0x00,0x01,0x1F,0xFF,0xFF,0xFE,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x0B,0xFF + fcb 0x9F,0xFF,0xFD,0xF8,0x00,0x00,0x00,0x01,0xBF,0xFF,0xFF,0xFF,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x07,0xFF + fcb 0xFF,0xFF,0x8F,0xE8,0x00,0x00,0x00,0x01,0xBF,0xFF,0xFF,0xFC,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x07,0xFF + fcb 0xFF,0xFF,0xFF,0xF8,0x00,0x00,0x00,0x01,0xBF,0xFF,0xFF,0xF8,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x07,0xFF + fcb 0xFF,0x9F,0xFF,0xF8,0x00,0x00,0x00,0x01,0x3F,0xFF,0xFF,0xF0,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFE,0x00,0x00,0x07,0xFF + fcb 0x1F,0xFF,0xF5,0xFC,0x00,0x00,0x00,0x01,0x3F,0xFF,0xFF,0xE0,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x03,0xFC + fcb 0x3F,0xFF,0xBF,0xF8,0x00,0x00,0x00,0x01,0x3F,0x85,0xFF,0xC0,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x03,0xFF + fcb 0xF7,0xFF,0xDF,0xF8,0x00,0x00,0x00,0x00,0x1D,0x2A,0x07,0x80,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x0E,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x07,0xFF + fcb 0xFF,0xFF,0xFF,0xF8,0x00,0x00,0x00,0x01,0x06,0xFF,0x00,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x1C,0x00,0x00,0x00,0x00,0x00,0x00,0x10,0x00,0x00,0x1F,0xFF + fcb 0xFF,0xFF,0xDF,0xF8,0x00,0x00,0x00,0x01,0x17,0x3D,0x95,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x01,0xFF,0x80,0x00,0x07,0xFF + fcb 0xFF,0xFF,0xEF,0xF8,0x00,0x00,0x00,0x00,0x0E,0xEF,0xDA,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x03,0xFF + fcb 0xFF,0xFF,0xF7,0xF0,0x00,0x00,0x00,0x00,0x15,0xF7,0x80,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x03,0xFF + fcb 0xFF,0xFF,0xED,0xE0,0x00,0x00,0x00,0x00,0x0F,0xBF,0xEC,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x07,0xFF + fcb 0xFF,0xFF,0xDC,0xE0,0x00,0x00,0x00,0x00,0x17,0x7F,0xD8,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x07,0xFF + fcb 0xFF,0xFF,0xBC,0xC0,0x00,0x00,0x00,0x00,0x3F,0xFF,0xF8,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x03,0xFF + fcb 0xFF,0xFF,0xDE,0x00,0x00,0x00,0x00,0x00,0x7F,0xFF,0xF8,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x01,0xFF + fcb 0xFF,0xFF,0xFF,0x80,0x00,0x00,0x00,0x00,0x7F,0xFF,0xF8,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF + fcb 0xFF,0xFB,0xFF,0x80,0x00,0x00,0x00,0x00,0x7F,0xFF,0xF0,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x03,0xDF + fcb 0xFE,0xC1,0xF2,0x00,0x00,0x00,0x00,0x18,0x7F,0xFF,0xF0,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x83 + fcb 0x00,0x1F,0xCC,0x00,0x00,0x00,0x00,0x00,0x7F,0xFF,0xF0,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x03,0x00 + fcb 0x80,0x3F,0x98,0x00,0x00,0x00,0x00,0x00,0x7F,0xFF,0xF0,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xE2 + fcb 0x46,0x3E,0x60,0x00,0x00,0x00,0x00,0x00,0x7F,0xFF,0xE0,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x01,0x80 + fcb 0x33,0x3C,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xC0,0x60,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xA0 + fcb 0x73,0x10,0x00,0x00,0x00,0x00,0x00,0x00,0x15,0x3A,0x80,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xE0 + fcb 0x08,0x18,0x00,0x00,0x00,0x00,0x00,0x00,0x02,0xF6,0x00,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xE0 + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x17,0xB6,0x00,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x02,0xED,0x80,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x05,0x2C,0x00,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x20,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x02,0xB0,0x80,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x70,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x7F,0xFF,0x00,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x78,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x40,0x00,0x00,0x00,0x7F,0xFF,0x80,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x40,0x00,0x00,0x00,0x7F,0xFF,0xC0,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x7F,0xFF,0x80,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x7F,0xFF,0x80,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x7F,0xFF,0x80,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xF7,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x7F,0xFF + fcb 0xFF,0xF7,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x7F,0xFF + fcb 0xFF,0xF7,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x7F,0xFF + fcb 0xFF,0xF7,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x7F,0xFF + fcb 0xFF,0xF7,0xFF,0xFF,0x3C,0xFF,0xF3,0x3F,0xFF,0xCF,0x9F,0xFF,0xFF,0xFF,0x03,0xFF + fcb 0xCC,0xFF,0xFF,0xF3,0xFF,0xFF,0xF8,0x1F,0xFE,0x0F,0xFF,0x8F,0xFF,0xFF,0x7F,0xFF + fcb 0xFF,0xF7,0xFF,0xFF,0x18,0xFF,0xF3,0x3F,0xFF,0xCF,0xFF,0xFF,0xFF,0xFF,0xCF,0xFF + fcb 0xCC,0xFF,0xFF,0xFF,0xFF,0xFF,0xFE,0x7F,0xFE,0x7F,0xFF,0xCF,0xFF,0xFF,0x7F,0xFF + fcb 0xFF,0xF7,0xFF,0xFF,0x00,0xFF,0xF3,0x31,0x9E,0x49,0x10,0xE1,0xFF,0xFF,0xCF,0xFF + fcb 0xCC,0xC6,0x08,0x23,0x0F,0xFF,0xFE,0x7F,0xFE,0x7C,0x60,0xCC,0x70,0xFF,0x7F,0xFF + fcb 0xFF,0xF7,0xFF,0xFF,0x24,0xFF,0xF0,0x3C,0xC0,0xC3,0x92,0x4F,0xFF,0xFF,0xCF,0xFF + fcb 0xC0,0xF2,0x38,0xF2,0x7F,0xFF,0xFE,0x7F,0xFE,0x1F,0x23,0xC9,0x27,0xFF,0x7F,0xFF + fcb 0xFF,0xF7,0xFF,0xFF,0x3C,0xFF,0xF3,0x30,0xC0,0xC7,0x92,0x63,0xFF,0xFF,0xCF,0xFF + fcb 0xCC,0xC2,0x79,0xF3,0x1F,0xFF,0xFE,0x7F,0xFE,0x7C,0x27,0xC8,0x31,0xFF,0x7F,0xFF + fcb 0xFF,0xF7,0xFF,0xFF,0x3C,0xFF,0xF3,0x24,0xE1,0xC3,0x92,0x79,0xFF,0xFF,0xCF,0xFF + fcb 0xCC,0x92,0x79,0xF3,0xCF,0xFF,0xFE,0x7F,0xFE,0x79,0x27,0xC9,0xFC,0xFF,0x7F,0xFF + fcb 0xFF,0xF7,0xFF,0xFF,0x3C,0x9F,0xF3,0x30,0xE1,0xC9,0x92,0x43,0xFF,0xFF,0xCE,0x7F + fcb 0xCC,0xC2,0x79,0xF2,0x1F,0xFF,0xFE,0x73,0xFE,0x0C,0x27,0xCC,0x61,0xFF,0x7F,0xFF + fcb 0xFF,0xF7,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x7F,0xFF + fcb 0xFF,0xF7,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x7F,0xFF + fcb 0xFF,0xF7,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x7F,0xFF + fcb 0xFF,0xF7,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x7F,0xFF + fcb 0xFF,0xF7,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x7F,0xFF + fcb 0xFF,0xF0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x7F,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF +AUTHPICe equ * +; Unused + fcb 0xFF,0x00,0x00,0xA0,0x27,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xEF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF + fcb 0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x40,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; The actual Super Extended Basic (SECB) extensions start here. +; +; Note that many routines in this area feature a "lbrn 0" instruction. This appears to be intended as a placeholder to allow +; patching into the routines similar to the RAM hooks in Color Basic except using direct overwiting of the instruction. It's +; completely pointless and probably illustrates that the writers of this code didn't really think through what they were doing. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +SUPERVAR fdb HRMODE ; address of direct page variables unique to SECB +PRGTEXT fdb SETTEXT ; set video registers for text mode (indirect) +PRGGRAPH fdb SETGRAPH ; set video registers for graphics mode (indirect) +PRGMMU fdb SETMMU ; set MMU registers to their "default" (indirect) +GETTEXT fdb SELTEXT ; put hi-res text screen in logical block 1 (indirect) +GETBLOK0 fdb SELBLOK0 ; put block in B in logical block 0 (indirect) +GETTASK0 fdb SELTASK0 ; re-select MMU task 0 (indirect) +GETTAKS1 fdb SELTASK1 ; select MMU task 1(indirect) + jmp LA05E ; execute non-self starting ROM +SPARE0 fdb 0 ; undefined +SPARE1 fdb 0 ; undefined +SPARE2 fdb 0 ; undefined +; Set up video registers for the selected text screen. Given that the sets of video mode initializers are contiguous in +; memory, this would probably be better done with a simple sequence of MUL and ABX. +SETTEXT pshs y,x,a ; save registers + lbrn 0 + ldx #IM.TEXT ; point to 32 column video mode registers + lda HRWIDTH ; get text mode + beq SETVIDEO ; brif 32 column + ldx #SE03B ; point to 40 column mode data + cmpa #1 ; is it 40 column? + beq SETVIDEO ; brif so + ldx #SE044 ; assume 80 column + bra SETVIDEO ; program video registers +; 32 column (VDG) initializer +IM.TEXT fcb COCO+MMUEN+MC3+MC2 ; INIT0 (COCO bit enables VDG modes) + fcb 0x00 ; VIDEOMOD (unused for VDG modes) + fcb 0x00 ; VIDEORES (unused for VDG modes) + fcb 0x00 ; V.BORDER (black) + fcb 0x00 ; filler for reserved + fcb 0x0f ; V.SCROLL - this value is needed to show a proper 12 lines per text row + fdb 0xe000 ; V.OFFSET - SAM offsets operate in 0x7xxx + fcb 0x00 ; H.OFFSET - no horizontal offset +; 40 column screen +SE03B fcb MMUEN+MC3+MC2 ; INIT0 (disable VDG modes) + fcb 0x03 ; VIDEOMOD - 8 lines per row + fcb 0x05 ; VIDEORES - 40 columns, attributes enabled, 192 lines per field + fcb 0x12 ; V.BORDER - nuclear green + fcb 0x00 ; filler for reserved + fcb 0x00 ; V.SCROLL - no offset + fdb 0xd800 ; V.OFFSET - screen at 0x6c000 + fcb 0x00 ; H.OFFSET - no offset +; 80 column screen +SE044 fcb MMUEN+MC3+MC2 ; INIT0 (disable VDG modes) + fcb 0x03 ; VIDEOMOD - 8 lines per row + fcb 0x15 ; VIDEORES - 80 columns, attributes enabled, 192 lines per field + fcb 0x12 ; V.BORDER - nuclear green + fcb 0x00 ; filler for reserved + fcb 0x00 ; V.SCROLL - no offset + fdb 0xd800 ; V.OFFSET - screen at 0x6c000 + fcb 0x00 ; H.OFFSET - no offset +; Set up video registers for the selected "HSCREEN" mode. Note that the two code paths for the resolution widths +; are unneeded. +SETGRAPH pshs y,x,a ; save registers + lbrn 0 + ldx #IM.GRAPH ; point to graphics initlializer + ldy #RESTABLE ; point to resolution bytes table + lda HRMODE ; get graphics mode + cmpa #2 ; is it a 640 pixel mode? + bls SE063 ; brif not + ldx #SE079 ; point to 640 pixel registers +SE063 suba #1 ; normalize mode numbers to start at 0 + lda a,y ; get resolution setting for this mode + sta 2,x ; put it in the graphics mode initializer + jmp SETVIDEO ; go set up video registers +RESTABLE fcb 0x15 ; 320x192, 4 colours + fcb 0x1e ; 320x192, 16 colours + fcb 0x14 ; 640x192, 2 colours + fcb 0x1d ; 640x192, 4 colours +; 320x192 graphics modes +IM.GRAPH fcb MMUEN+MC3+MC2 ; INIT0 (disable VDG modes) + fcb 0x80 ; VIDEOMOD - enable bit plane, one line per row + fcb 0x00 ; VIDEORES - placeholder + fcb 0x00 ; V.BORDER - black + fcb 0x00 ; filler for reserved + fcb 0x00 ; V.SCROLL - no offset + fdb 0xc000 ; V.OFFSET - screen at 0x60000 + fcb 0x00 ; H.SCROLL - no offset +; 640x192 graphics modes (observe that these are identical to the 320x192 ones above) +SE079 fcb MMUEN+MC3+MC2 ; INITo (disable VDG modes) + fcb 0x80 ; VIDEOMOD - enable bit plane, one line per row + fcb 0x00 ; VIDEORES - placeholder + fcb 0x00 ; V.BORDER - black + fcb 0x00 ; filler for reserved + fcb 0x00 ; V.SCROLL - no offset + fdb 0xc000 ; V.OFFSET - screen at 0x60000 + fcb 0x00 ; H.SCROLL - no offset +; Program video registers and INIT0 from (X); enter with A,X,Y pre-saved +SETVIDEO lda ,x+ ; set INIT0 + sta INIT0 + ldy #VIDEOMOD ; point to start of video mode registers +SE08B lda ,x+ ; set a register + sta ,y+ + cmpy #MMUREG ; done all of them? + blo SE08B ; brif not + puls a,x,y,pc ; restore registers and return +; Set MMU registers to their default values. All 16 of them. +SETMMU pshs y,x,b,a ; save registers + leax IM.MMU,pcr ; point to MMU initializer + bsr SE0F1 ; program MMU registers + puls a,b,x,y,pc ; restore registers and return +; Set logical block 0 to the physical block in B. This is embarassingly inefficient since it sets +; *all 16* MMU registers to change one of them. All the faffing about with pointers and the call +; to set the MMU registers is pointless. It could be done with a single STB. +SELBLOK0 pshs y,x,b,a ; save registers + leax IM.MMU,pcr ; point to MMU initializer + pshs x ; save it for later + stb ,x ; set desired block in initializer + bsr SE0F1 ; program *all 16* MMU registers (stupid) + ldb #BLOCK7.0 ; get correct block number for logical block 0 + puls x ; get back pointer to the initializer + stb ,x ; restore initializer value + puls a,b,x,y,pc ; restore registers and return +; Put hi-res text screen in logical address space block 1. This is embarassingly ineffecient since +; it sets *all 16* MMU registers to change only one. All the faffing about with pointers and the +; call to set the MMU registers is pointless. It could be done with a singel LD/ST sequence. +SELTEXT pshs y,x,b,a ; save registers + leax IM.MMU,pcr ; point to MMU initializer + pshs x ; save pointer for later + ldb #BLOCK6.6 ; get block number for text screen + stb 1,x ; put in logical block 1 of initializer + bsr SE0F1 ; program *all 16* MMU registers (stupid) + puls x ; get back pointer + ldb #BLOCK7.1 ; get proper block for logical block 1 + stb 1,x ; put it back in the initializer + puls a,b,x,y,pc ; restore registers and return +; Get block 6.4 (HBUFF buffers) to logical block 6 of task 1. This is embarassingly inefficient +; since it sets *all 16* MMU registers to change only one. All the faffing about with pointers and +; the call to set the MMU registers ispointless. It could be done with a single LD/ST sequence. +SE0CB pshs y,x,b,a ; save registers + leax IM.MMU,pcr ; point to MMU initializer + pshs x ; save pointer for later + ldb #BLOCK6.4 ; get block for the HBUFF buffers + stb 14,x ; put in logical block 6, task 1 + bsr SE0F1 ; program *all 16* MMU registers (stupid) + puls x ; get back pointer + ldb #BLOCK6.5 ; get default block for logical block 6 of task 1 + stb 14,x ; put it back in the initializer + puls a,b,x,y,pc ; restore registers and return +; MMU initializer +IM.MMU fcb BLOCK7.0,BLOCK7.1,BLOCK7.2,BLOCK7.3 ; task 0: map 0x70000-0x7ffff + fcb BLOCK7.4,BLOCK7.5,BLOCK7.6,BLOCK7.7 + fcb BLOCK7.0,BLOCK6.0,BLOCK6.1,BLOCK6.2 ; task 1: put hires gfx at 0x2000 and a stack block at 0xc000 + fcb BLOCK6.3,BLOCK7.5,BLOCK6.5,BLOCK7.7 +; Set all 16 MMU registers from the initializer pointed to by X. +SE0F1 ldy #MMUREG ; point to MMU registers + ldb #16 ; there are 16 to set +SE0F7 lda ,x+ ; set a register + sta ,y+ + decb ; done all? + bne SE0F7 ; brif not + rts +; Select task register 0 as the active MMU set. Enter with stack in a temporary location which +; holds the original stack pointer. Note that the return could be done simply as jmp [V42] instead +; of pushing the return address onto the stack. Interrupts will be enabled on the way out. +SELTASK0 std V40 ; temp save D + ldd ,s ; get return address + std V42 ; save it + ldd 2,s ; get original stack pointer + std V44 ; save it + clrb ; reset INIT1 to task 0 (and slow timer), could just be CLR INIT1 + stb INIT1 + lds V44 ; restore original stack pointer + ldd V42 ; get back return address + pshs d ; set return address on stack + ldd V40 ; get back original D + andcc #0xaf ; re-enable interrupts + rts +; Select task register 1 as the active MMU set. Exit with interrupts disabled and the original +; stack pointer saved at the top of the temporary stack. Note that jmp [V42] could be used to +; return instead of pushing the return address back on the stack. +SELTASK1 orcc #0x50 ; disable interrupts + std V40 ; temp save D + puls d ; get return address + std V42 ; save it + sts V44 ; save stack pointer + ldb #1 ; set to enable task 1, slow timer input + stb INIT1 + lds #TMPSTACK ; point to temporary stack location (top of the C000-Dfff range) + ldd V44 ; get old stack pointer + pshs d ; stash it + ldd V42 ; put original return address back + pshs d + ldd V40 ; restore original D + rts +; Tokenziation patch +ALINK2 tst V41 ; is it a function token? + bne SE152 ; brif so + lda V42 ; get token value + cmpa #0x62 ; have we reached the first SECB token? + bls SE148 ; brif not + ldu #COMVEC-5 ; point to function table and go again + jmp LB8D7 ; re-enter mainline code +SE148 lda #0x62 ; force tokens to start at the correct number (above Disk Basic) + ldu #EBCOMTAB-10 ; point to SECB command table +SE14D sta V42 ; set token counter to SECB values + jmp LB89D ; re-enter mainstream still in command mode +SE152 lda V42 ; get token number + cmpa #0x29 ; have we run through SECB functions yet? + bls SE15B ; brif not + jmp LB8D7 ; re-enter mainline code (end of processing) +SE15B lda #0x29 ; force token into SECB range (this leaves one unused) + ldu #EBCOMTAB-5 ; point to SECB function table + bra SE14D ; go transfer control back to mainline with new settings +EBCOMTAB fcb 23 ; number of keywords (commands) + fdb COMDIC20 ; keyword table (commands) + fdb ALINK4 ; interpretation handler (commands) + fcb 5 ; number of keywords (functions) + fdb FUNDIC20 ; keyword table (functions) + fdb ALINK5 ; interpretation handler (functions) + fcb 0x00,0x00,0x00,0x00,0x00,0x00 ; marker for no further tables +; Detokenization patch. This routine has a bug. It freezes if an unknown token is encountered instead +; of using the placeholder. +ALINK3 leau 10,u ; move to next table + tst ,u ; valid table? + lbne LB7F9 ; brif so - re-enter mainline code + leax -1,x ; get token number + lda ,x+ + anda #0x7f ; remove token bias + cmpa #0x62 ; SECB command? + blo SE18B ; brif not + suba #0x62 ; zero-base SECB token number + ldu #EBCOMTAB-10 ; point to command table + bra ALINK3 ; go try again +SE18B suba #0x29 ; zero-base function token + ldu #EBCOMTAB-5 ; point to SECB function table + bra ALINK3 ; go try again +; Command interpretation patch +ALINK4 cmpa #0xe2 ; is it within the SECB range? + blo SE19A ; brif not (below) + cmpa #0xf8 ; is it above range? + bls SE19E ; brif not - we have a SECB command +SE19A jmp [COMVEC+23] ; transfer control onward to Disk Basic +SE19E suba #0xe2 ; normalize SECB commands to 0 + ldx #COMDIS20 ; point to jump table for SECB commands + jmp LADD4 ; go dispatch command +; Function processing patch +ALINK5 cmpb #0x29*2 ; is it an SECB function? + blo SE1AE ; brif not (below) + cmpb #0x2d*2 ; is it still an SECB function? + bls SE1B2 ; brif so +SE1AE jmp [COMVEC+28] ; transfer control to Disk Basic +SE1B2 subb #0x29*2 ; normalize SECB functions to 0 + cmpb #2*2 ; do we need to parse a parameter? + bhs SE1BF ; brif not + pshs b ; save token offset + jsr LB262 ; parse parenthetical expression + puls b ; get back token offset +SE1BF ldx #FUNDIS20 ; point to jump table for SECB functions + jmp LB2CE ; go dispatch function call +; Keyword table (commands) for SECB +COMDIC20 fcs 'WIDTH' ; 0xe2 + fcs 'PALETTE' ; 0xe3 + fcs 'HSCREEN' ; 0xe4 + fcs 'LPOKE' ; 0xe5 + fcs 'HCLS' ; 0xe6 + fcs 'HCOLOR' ; 0xe7 + fcs 'HPAINT' ; 0xe8 + fcs 'HCIRCLE' ; 0xe9 + fcs 'HLINE' ; 0xea + fcs 'HGET' ; 0xeb + fcs 'HPUT' ; 0xec + fcs 'HBUFF' ; 0xed + fcs 'HPRINT' ; 0xee + fcs 'ERR' ; 0xef + fcs 'BRK' ; 0xf0 + fcs 'LOCATE' ; 0xf1 + fcs 'HSTAT' ; 0xf2 + fcs 'HSET' ; 0xf3 + fcs 'HRESET' ; 0xf4 + fcs 'HDRAW' ; 0xf5 + fcs 'CMP' ; 0xf6 + fcs 'RGB' ; 0xf7 + fcs 'ATTR' ; 0xf8 +; Jump table for SECB commands +COMDIS20 fdb WIDTH ; 0xe2 WIDTH + fdb PALETTE ; 0xe3 PALETTE + fdb HSCREEN ; 0xe4 HSCREEN + fdb LPOKE ; 0xe5 LPOKE + fdb HCLS ; 0xe6 HCLS + fdb HCOLOR ; 0xe7 HCOLOR + fdb HPAINT ; 0xe8 HPAINT + fdb HCIRCLE ; 0xe9 HCIRCLE + fdb HLINE ; 0xea HLINE + fdb HGET ; 0xeb HGET + fdb HPUT ; 0xec HPUT + fdb HBUFF ; 0xed HBUFF + fdb HPRINT ; 0xee HPRINT + fdb ERR ; 0xef ERR (should be LB277) + fdb BRK ; 0xf0 BRK (should be LB277) + fdb LOCATE ; 0xf1 LOCATE + fdb HSTAT ; 0xf2 HSTAT + fdb HSET ; 0xf3 HSET + fdb HRESET ; 0xf4 HRESET + fdb HDRAW ; 0xf5 HDRAW + fdb CMP ; 0xf6 CMP + fdb RGB ; 0xf7 RGB + fdb ATTR ; 0xf8 ATTR +; Keyword table for SECB functions +FUNDIC20 fcs 'LPEEK' ; 0xa9 + fcs 'BUTTON' ; 0xaa + fcs 'HPOINT' ; 0xab + fcs 'ERNO' ; 0xac + fcs 'ERLIN' ; 0xad +; Jump table for SECB functions +FUNDIS20 fdb LPEEK ; 0xa9 LPEEK + fdb BUTTON ; 0xaa BUTTON + fdb HPOINT ; 0xab HPOINT + fdb ERNO ; 0xac ERNO + fdb ERLIN ; 0xad ERLIN +; Signon message patch +ALINK12 ldx #L80E8-1 ; point to ECB's message + jsr STRINOUT ; display it + ldx #MWAREMS-1 ; point to Microware string + jsr STRINOUT ; display it + jmp L80B8 ; return to mainline code +; Signon message patch for Disk Basic 1.0 +ALINK28 ldx #DISK20MS-1 ; point to modified message + jmp DC0DC-19 ; return to mainline code +; Signon message patch for Disk Basic 1.1 +ALINK29 ldx #DISK21MS-1 ; point to modified message + jmp DC0DC ; return to mainline code +DISK20MS fcc 'DISK EXTENDED COLOR BASIC 2.0' + fcb 0x0d + fcc 'COPR. 1981, 1986 BY TANDY' + fcb 0x0d + fcc 'UNDER LICENSE FROM MICROSOFT' + fcb 0x0d +MWAREMS fcc 'AND MICROWARE SYSTEMS CORP.' + fcb 0x0d,0x0d,0x00 +DISK21MS fcc 'DISK EXTENDED COLOR BASIC 2.1' + fcb 0x0d + fcc 'COPR. 1982, 1986 BY TANDY' + fcb 0x0d + fcc 'UNDER LICENSE FROM MICROSOFT' + fcb 0x0d + fcc 'AND MICROWARE SYSTEMS CORP.' + fcb 0x0d,0x0d,0x00 +; Extended Basic extra initialization patch +ALINK14 clra ; set up to clear things + clrb + lbrn 0 + stb H.CRSATT ; reset cursor attributes + std HRMODE ; reset to VDG screen and no HSCREEN graphics + std H.ONBRK ; reset ON BRK destination + std H.ONERR ; reset ON ERR destinatin + sta H.BCOLOR ; default HSCREEN background to 0 + lda #1 ; default HSCREEN foreground to 1 + sta H.FCOLOR + lda #BLOCK6.4 ; map the HGET/HPUT buffers + sta MMUREG + ldd #0xffff ; mark as empty + std 0 + lda #BLOCK7.0 ; restore memory map + sta MMUREG + jmp LAD19 ; go finish initializing (NEW) +; ON command patch +ALINK18 cmpa #0xef ; ERR? + beq ERR ; brif so + cmpa #0xf0 ; BRK? + beq BRK ; brif so + jsr EVALEXPB ; evaluate the ON index argument + jmp LAF45 ; return to mainline code +SE3C2 jsr GETNCH ; eat the ERR/BRK token + cmpa #0x81 ; GO? + bne SE3CF ; brif not + jsr GETNCH ; eat the GO + cmpa #0xa5 ; TO? + bne SE3CF ; brif not + rts +SE3CF leas 2,s ; clean up stack (not needed) + jmp LB277 ; raise syntax error +; ERR jumps here if used as a command +; NOTE: you can do ERR <char> GOTO (where <char> is a single character that doesn't prevent GOTO from being tokenized +ERR bsr SE3C2 ; check for GOTO + jsr GETNCH ; eat the "TO" + jsr LAF67 ; evaluate destination line number + ldd BINVAL ; get line number + std H.ONERR ; set error destination + ldd CURLIN ; get current line number + std H.ONERRS ; save line number where ON ERR was executed + rts +; BRK jump shere if used as a command. +; Same note as for ERR applies. +BRK bsr SE3C2 ; check for GOTO + jsr GETNCH ; eat the "TO" + jsr LAF67 ; evaluate destination line number + ldd BINVAL ; get line number + std H.ONBRK ; set break destination + ldd CURLIN ; get current line number + std H.ONBRKS ; save line number where ON BRK was executed + rts +; Patches for &H parsing +ALINK6A lsl 2,x ; multiply accumulator by 2 + rol 1,x + rol ,x + lbcs LBA92 ; brif we overflowed + decb ; done enough shifts? + bne ALINK6A ; brif not + suba #'0 ; remove ASCII bias + adda 2,x ; add digit to accumulator (this cannot cause carry) + sta 2,x + rts +ALINK6B lbcs L8800 ; brif numeric + jmp L883F ; return to mainline +; Line input patch +ALINK16 cmpa #3 ; is it BREAK? + orcc #1 ; set C for BREAK + bne SE426 ; brif not BREAK + pshs a,cc ; save character and break status + lda HRMODE ; is it graphics mode? + beq SE424 ; brif not + clr HRMODE ; disable graphics mode + jsr SETTEXT +SE424 puls cc,a ; get back BREAK status and character +SE426 jmp LA3C6 ; return to mainline +; Break check patch +ALINK15 cmpa #3 ; BREAK? + beq SE430 ; brif so + jmp LADF4 ; re-enter mainline +SE430 lda #1 ; BREAK flag + sta H.ERRBRK + lda CURLIN ; immediate mode? + inca + beq SE43F ; brif so + ldd H.ONBRK ; is ON BRK active? + bne SE449 ; brif so +SE43F lda HRMODE ; graphics m ode? + beq SE446 ; brif not + jsr SETTEXT ; set text mode +SE446 jmp STOP ; go handle BREAK +SE449 std BINVAL ; set destination line number + tst H.ERRBRK ; error or break? + bne SE458 ; brif break + lds FRETOP ; reset stack pointer + ldd #LADC4 ; return to main loop + pshs d +SE458 jsr LAEEB ; move to end of line + leax 1,x ; move past line terminator + ldd BINVAL ; get desired line number + cmpd CURLIN ; is it here or later? + bhi SE466 ; brif so + ldx TXTTAB ; start search at beginning +SE466 jsr LAD05 ; find program line + lbcs SE51E ; brif not found + jmp LAEBB ; reset input pointer and return to main loop +; Error handling patch +ALINK20 clr H.ERRBRK ; flag error handling + lda CURLIN ; immediate mode? + inca + beq SE47D ; brif so + ldx H.ONERR ; is ON ERR in effect + bne SE4B3 ; brif so +SE47D pshs a ; save register + lda HRMODE ; set flags on graphics mode + puls a ; get back A + beq SE488 ; brif not graphics mode + jsr SETTEXT ; force text mode +SE488 cmpb #38*2 ; HG error? + bne SE49F ; brif not + jsr LB95C ; do newline + jsr LB9AF ; do ? + leax BAS20ERR,pcr ; point to error string +SE496 jsr LACA0 ; display two character error message + jsr LACA0 + jmp LAC65 ; return to mainline code +SE49F cmpb #39*2 ; HP error? + bne SE4B0 ; brif not + jsr LB95C ; do newline + jsr LB9AF ; do ? + leax BAS20ERR+2,pcr ; point to error string + jmp SE496 ; go finish up +SE4B0 jmp LAC49 ; return to mainline error handler +SE4B3 stb H.ERROR ; save error number + pshs b ; save error number + ldd CURLIN ; get current line number + std H.ERLINE ; save line number where error occurred + puls b ; get back error number + cmpb #3*2 ; OD error? + bne SE4C7 ; brif not + ldd BINVAL ; restore input pointer + std CHARAD +SE4C7 tfr x,d ; save error destination line + lbra SE449 ; go transfer control to error handler +BAS20ERR fcc 'HR' ; 38 Hi resolution graphics error + fcc 'HP' ; 39 Hi resolutuion print error +; NEW handling patch +ALINK19 pshs d ; save D + clra ; set up to clear things + clrb + std OLDPTR ; reset CONT address + std H.ONBRK ; reset ON BRK line + std H.ONERR ; reset ON ERR line + std H.ERLINE ; reset error source line + lda #0xff ; set error number to -1 + sta H.ERROR + puls d ; restore d + jmp LAD43 ; return to mainline +; ERNO function +ERNO clra ; zero extend error number + ldb H.ERROR ; get error number + cmpb #0xff ; real? + bne SE4F4 ; brif so + sex ; return "-1" + bra SE4FA +SE4F4 cmpb #0xf1 ; error number 0xf1? + bne SE4F9 ; brif not + comb ; turn it back into UL error +SE4F9 asrb ; error numbers are pre-multiplied by 2 - undo that +SE4FA jmp GIVABF ; return error number +; ERLIN function +ERLIN ldd H.ERLINE ; get the line number where the error occurred + bra SE4FA ; return it - BUG: will treat lines above 32767 as negative +; Immediate mode patch +ALINK21 jsr SETTEXT ; force text mode + jsr LB95C ; do line feed if needed + orcc #0x50 ; disable interrupts + lda #BLOCK6.4 ; map HGET/HPUT buffers + sta MMUREG + ldd #0xffff ; mark buffers empty + std 0 + lda #BLOCK7.0 ; restore memory map + sta MMUREG + andcc #0xaf ; re-enable interrupts + jmp LAC76 ; return to mainline +; Handle undefined line in ON ERR or ON BRK +SE51E tst H.ERRBRK ; break? + beq SE528 ; brif not + ldd H.ONBRKS ; get line number where ON BRK is + bra SE52B +SE528 ldd H.ONERRS ; get line number where ON ERR is +SE52B std CURLIN ; reset the current line number there + ldb #7*2 ; undefined line number + jmp LAC49 ; raise error (bypass ON ERR check) +; INPUT patch +ALINK17 ldd H.ONBRK ; is ON BRK operating? + lbeq LAE11 ; brif not + pshs d ; save destination line + lda #1 ; set BREAK flag + sta H.ERRBRK + puls d ; get destination line + lbra SE449 ; go handle ON BRK in INPUT +; LPOKE command +LPOKE jsr LB141 ; evaluate numeric expression (address) + lbrn 0 + bsr SE58E ; convert to extended address + cmpb #BLOCK7.7 ; valid block number? + lbhi LB44A ; brif not + pshs x,b ; save block and offset + jsr SYNCOMMA ; require a comma + jsr EVALEXPB ; evaluate value to put in memory + tfr b,a ; save value in A + puls b,x ; get back block and offset + cmpb #BLOCK7.7 ; valid block (we already tested this!!) + lbhi LB44A ; brif not + orcc #0x50 ; clobber interrupts + lbsr SELBLOK0 ; map the block (by writing *all 16* MMU registers) + sta ,x ; save byte in memory + lbsr SETMMU ; unmap block (by writing *all 16* MMU registers) + andcc #0xaf ; re-enable interrupts + rts +; LPEEK function +LPEEK bsr SE58E ; convert to block and offset + lbrn 0 + cmpb #BLOCK7.7 ; valid block? + lbhi LB44A ; brif not + orcc #0x50 ; clobber interrupts + lbsr SELBLOK0 ; map the block (by writing *all 16* MMU registers) + ldb ,x ; get memory contents + lbsr SETMMU ; restore map (by writing *all 16* MMU registers) + andcc #0xaf ; re-enable interrupts + jmp LB4F3 ; return B as unsigned +SE58E pshs a ; save register + lda FP0EXP ; is it in range for 0x80000? + cmpa #0x93 + bls SE59A ; brif so + ldb #BLOCK7.7+1 ; return illegal block number + bra SE5AF +SE59A jsr LBCC8 ; shift binary point to right of mantissa + ldd FPA0+2 ; get low bits + anda #0x1f ; mask off block number bits + tfr d,x ; now X has the block offset + ldd FPA0+1 ; get high bits + asra ;* shift block number to the right of B; note that + rorb ;* asr *should* be lsr but it works here because of + asra ;* the maximum range of the value + rorb + asra + rorb + asra + rorb + asra + rorb +SE5AF puls a,pc ; restore registers and return +; BUTTON command +BUTTON jsr INTCNV ; get button number + lbrn 0 + cmpb #3 ; button number in range? + lbhi LB44A ; raise error if not + tfr b,a ; save button number + clrb ; set B to 0xff (strobe no keyboard columns) + comb + ldx #PIA0 ; point to PIA0 + stb 2,x ; strobe nothing + ldb ,x ; get button data + cmpb #0x0f ; buttons are on bottom four rows + beq SE5EA ; brif no buttons down + leax SE5D5,pcr ; point to button mask routines + asla ; four bytes per button routine + asla + jmp a,x ; jump to appropriate routine +SE5D5 andb #1 ; keep button 1, right joystick + bra SE5E3 + andb #4 ; keep button #1, left joystick + bra SE5E3 + andb #2 ; keep button #2, right joystick + bra SE5E3 + andb #8 ; keep button #2, left joystick +SE5E3 bne SE5EA ; brif button was not down + ldd #1 ; return nonzero if button down + bra SE5EC ; return result +SE5EA clra ; return zero if not down + clrb +SE5EC jsr GIVABF ; return result + rts +; PALETTE command +PALETTE cmpa #0xf7 ; RGB? + lbrn 0 + bne SE600 ; brif not + jsr GETNCH ; munch the RGB +SE5FA leax IM.RGB,pcr ; point to RGB palette initializer + bra SE634 ; go set palette registers +SE600 cmpa #0xf6 ; CMP? + bne SE60C ; brif not + jsr GETNCH ; eat the CMP +SE606 leax IM.CMP,pcr ; point to CMP palette initializer + bra SE634 ; go set palette registers +SE60C jsr SE7B2 ; evaluate two expressions + ldx #PALETREG ; point to palette registers + ldy #IM.PALET ; point to palette register images + lda BINVAL+1 ; get palette number + cmpa #16 ; valid entry? + lbhs LB44A ; brif not 0-15 + leax a,x ; offset the pointers to the right entries + leay a,y + ldb VERBEG+1 ; get colour number + cmpb #63 ; valid? + bls SE62A ; brif so + ldb #63 ; maximize to 63 (white) +SE62A orcc #0x50 ; disable interrupts + sync ; synchronize to VSYNC + stb ,x ; set palette register + stb ,y ; record it in image + andcc #0xaf ; restore interrupts + rts +SE634 pshs x ; save source pointer + ldy #IM.PALET ; point to palette register live image + bsr SE648 ; copy source to the live image + puls x ; get source back + ldy #PALETREG ; point to palette registers + orcc #0x50 ; disable interrupts + sync ; synchronize to VSYNC + bsr SE648 ; copy the colour values into the palette registers + rts +SE648 ldb #16-1 ; BUG: should be 16 - this doesn't set register #15 +SE64A lda ,x+ ; set a register + sta ,y+ + decb ; done all? + bne SE64A ; brif not + andcc #0xaf ; re-enable interrupts + rts +IM.CMP fcb 18,36,11,7,63,31,9,38 ; palette values for CMP + fcb 0,18,0,63,0,18,0,38 +IM.RGB fcb 18,54,9,36,63,27,45,38 ; palette values for RGB + fcb 0,18,0,63,0,18,0,38 +; CMP and RGB commands just jump to the relevant implementations above +RGB bra SE5FA +CMP bra SE606 +IM.PALET fcb 18,36,11,7,63,31,9,38 ; live palette images + fcb 0,18,0,63,0,18,0,38 +; HSCREEN command +HSCREEN cmpa #0 ; end of line? BUG: won't work if colon terminates the command + lbrn 0 + bne SE693 ; brif not end of line + clrb ; default to HSCREEN 0 - turn off graphics + bra SE69C +SE693 jsr EVALEXPB ; evaluate HSCREEN argument + cmpb #4 ; only 4 HSCREEN modes + lbhi LB44A ; brif out of range +SE69C stb HRMODE ; set graphics mode + cmpb #0 ; HSCREEN 0? + bne SE6A5 ; brif not + jmp SETTEXT ; set text mode (disable graphics) +SE6A5 stb HRMODE ; set graphics mode (we already did!) + ldx #SE6CB ; point to bytes/row table + subb #1 ; normalize mode to 0 + lda b,x ; get bytes per row value + sta HORBYT ; set it + cmpb #1 ; is it 1 or 2? + bgt SE6B9 ; brif not + ldd #160 ; default coordinate for middle of 320 screen + bra SE6BC +SE6B9 ldd #320 ; default coordainte for middle of 640 screen +SE6BC std HORDEF ; set default horizontal coordinate + ldd #96 ; set default vertical coordinate to middle + std VERDEF + ldb H.BCOLOR ; get background colour + bsr CLRHIRES ; clear hi-res graphics screen + jmp SETGRAPH ; set up to display the screen +SE6CB fcb 80,160,80,160 ; bytes per row values for HSCREEN 1 through 4 +; HCLS command +HCLS bne SE6D6 ; brif not end of statement + ldb H.BCOLOR ; get background colour as default + bra CLRHIRES ; go clear screen +SE6D6 bsr SE70E ; evaluate colour number +CLRHIRES tst HRMODE ; graphics mode? + beq SE6EF ; brif not + bsr PIXELFIL ; get all pixels set byte + jsr SELTASK1 ; swap screen in + ldx #HRESSCRN ; point to start of screen +SE6E4 stb ,x+ ; set a byte worth of pixels + cmpx #HRESSCRN+0x8000 ; end of graphics memory? + bne SE6E4 ; brif not + jsr SELTASK0 ; restore memory map + rts +SE6EF ldb #38*2 ; code for HR error + jmp LAC46 ; raise error +; HCOLOR command +HCOLOR cmpa #', ; was a foreground colour given? + lbrn 0 + beq SE705 ; brif not + bsr SE70E ; evaluate colour number + stb H.FCOLOR ; save foreground colour + jsr GETCCH ; is there something after the foreground? + beq SE70D ; brif not +SE705 jsr SYNCOMMA ; insist on a comma + bsr SE70E ; evaluate colour number + stb H.BCOLOR ; set background colour +SE70D rts +; Evaluate a colour number and make sure it's between 0 and 15 inclusive +SE70E jsr EVALEXPB ; evaluate colour +SE711 cmpb #16 ; is it in range? + lbhs LB44A ; brif not + rts +SE718 jsr SE731 ; set working colour and pixel bytes to default + jsr GETCCH ; is there a colour number? + beq SE72F ; brif not + cmpa #') ; )? + beq SE72F ; brif so - no colour + jsr SYNCOMMA ; insist on a comma + cmpa #', ; another comma? + beq SE72F ; brif so - colour not specified + jsr SE70E ; evaluate colour + bsr SE73B ; set working colour and pixel bytes +SE72F jmp GETCCH ; get current character and return +SE731 ldb H.FCOLOR ; get foreground colour + tst SETFLG ; doing set? + bne SE73B ; brif so + ldb H.BCOLOR ; use background colour if doing reset +SE73B stb WCOLOR ; save working colour + bsr PIXELFIL ; get all pixel byte + stb ALLCOL ; save all pixel byte + rts +; Return B with all pixels set to colour number in B +PIXELFIL pshs x ; save registers + lda HRMODE ; get graphics mode + suba #1 ; normalize mode numbers to start at 0 + ldx #SE759 ; point to colour masks + andb a,x ; now B has only the relevant low bits of colour number + lda HRMODE ; get graphics mode + suba #1 ; normalize mode numbers to start at 0 + ldx #SE75D ; point to multiplier table + lda a,x ; get multplier + mul ; now B has all pixels set + puls x,pc ; restore registers and return +SE759 fcb 0x03,0x0f,0x01,0x03 ; colour masks to keep only necessary low bits +SE75D fcb 0x55,0x11,0xff,0x55 ; multipliers to duplicate colour value across all pixels +; HSET command +HSET lda #1 ; HSET flag + bra SE76A +; HRESET command +HRESET clra ; HRESET flag + lbrn 0 +SE76A tst HRMODE ; are we in a graphics mode? + beq SE6EF ; brif not - raise error + sta SETFLG ; save our set/reset state + jsr LB26A ; insist on ( + jsr SE7AA ; evaluate coordindates + tst SETFLG ; resetting? + bne SE77F ; brif so + jsr SE731 ; set working colour and pixel byte + bra SE782 +SE77F jsr SE718 ; evaluate colour number if present +SE782 jsr LB267 ; insist on a ) + jsr HCALPOS ; fetch screen pointer address and pixel mask +SE788 jsr SELTASK1 ; map the screen + jsr SE792 ; set or reset the pixel + jsr SELTASK0 ; unmap the screen + rts +SE792 ldb ,x ; get byte on screen + pshs b ; save it + tfr a,b ; duplicate mask + coma ; invert the mask for clearing the screen data + anda ,x ; reset the pixel + andb ALLCOL ; set pixel mask to correct colour + pshs b ; merge pixel colour into screen data + ora ,s+ + sta ,x ; put modified data on screen + suba ,s+ ; nonzero if the screen changed + ora CHGFLG ; merge with existing change flag + sta CHGFLG + rts +SE7AA jsr SE7B2 ; evaluate coordinates +SE7AD ldu #HORBEG ; point to horizontal coordinates +SE7B0 rts ; dummy "normalization" routine + rts ; pointles RTS +; Evaluate two expressions (usually coordinates) +SE7B2 jsr LB734 ; evaluate two expressions, first in BINVAL, second in B + ldy #HORBEG ; point to horizontal coordinates +SE7B9 cmpb #192 ; in range vertically? + blo SE7BF ; brif so + ldb #191 ; set to maximum coordinate +SE7BF clra ; zero extend vertical + std 2,y ; set vertical coordinate + lda HRMODE ; get graphics mode + cmpa #2 ; is it 1 or 2? + bgt SE7CD ; brif not + ldd #319 ; maximum coordinate for modes 1 and 2 + bra SE7D0 +SE7CD ldd #639 ; maximum coordindate for modes 3 and 4 +SE7D0 cmpd BINVAL ; is our max less than the specified one? + blo SE7D7 ; brif so - keep max + ldd BINVAL ; use specified coordinate +SE7D7 std ,y ; save horizontal coordinate + rts +; Calculate pixel mask and memory address for pixel +HCALPOS bsr SE7E6 ; point to correct routine for current mode + jmp ,u ; execute it +CALTABLE fdb G2BITPIX ; HSCREEN 1 + fdb G4BITPIX ; HSCREEN 2 + fdb G1BITPIX ; HSCREEN 3 + fdb G2BITPIX ; HSCREEN 4 +SE7E6 ldu #CALTABLE ; point to routine table + lda HRMODE ; get graphicsmode + suba #1 ; zero-base it + asla ; two bytes per address + ldu a,u ; get routine address + rts +PIX1MASK fcb 0x80,0x40,0x20,0x10,0x08,0x04,0x02,0x01 ; pixel masks for 1 bpp +PIX2MASK fcb 0xc0,0x30,0x0c,0x03 ; pxiel masks for 2 bpp +PIX4MASK fcb 0xf0,0x0f ; pixel masks for 4 bpp +G1BITPIX pshs u,b ; save registers + ldb HORBYT ; get bytes per row + lda VERBEG+1 ; get vergical coord + mul ; now D is the offset to the start of the row + addd #HRESSCRN ; add in start of screen in memory + tfr d,x ; put it in a pointer + ldd HORBEG ; get horiztonal coordindate + lsra ; 8 pixels per byte do divide by 8 + rorb + lsra + rorb + lsra + rorb + leax d,x ; offset to correct byte row + lda HORBEG+1 ; get pixel number + anda #7 ; keep only byte offset + ldu #PIX1MASK ; point to 1 bpp masks + lda a,u ; get pixel mask + puls b,u,pc ; restore registers and return +G2BITPIX pshs u,b ; save registers + ldb HORBYT ; get number of bytes per row + lda VERBEG+1 ; get horizontal coordinate + mul ; now D is the offset to the start of the row + addd #HRESSCRN ; add in memory offset to the screen + tfr d,x ; put that in a pointer + ldd HORBEG ; get horizontal coordinate + lsra ; 4 pixels per byte so divide by 4 + rorb + lsra + rorb + leax d,x ; now X points to the correct memory byte + lda HORBEG+1 ; get horizontal coordinate + anda #3 ; keep only the pixel number in the byte + ldu #PIX2MASK ; point to 2 bpp pixel masks + lda a,u ; get mask for this pixel + puls b,u,pc ; restore registers and return +G4BITPIX pshs u,b ; save registers + ldb HORBYT ; get bytes per row + lda VERBEG+1 ; get vertical coordinate + mul ; now D is the offset to the start of the row + addd #HRESSCRN ; add in memory address of start of screen + tfr d,x ; put it in a pointer + ldd HORBEG ; get horizontal coordinate + lsra ; divide by 2 - only 2 pixels per byte + rorb + leax d,x ; now X points to the memory address of the pixel + lda HORBEG+1 ; get horiztonal coordinate + anda #1 ; keep offset into byte + ldu #PIX4MASK ; point to 4 bpp pixel masks + lda a,u ; get pixel mask + puls b,u,pc ; restore registers and return +; HPOINT function +HPOINT tst HRMODE ; is there a graphics mode? + lbeq SE6EF ; brif not - raise error + jsr LB26A ; insist on ( + jsr SE7AA ; evaluate coordinates + jsr LB267 ; insist on ) + jsr SELTASK1 ; map the screen + jsr HCALPOS ; get screen pointer + tfr a,b ; save mask + andb ,x ; get pixel data +SE875 lsra ; is the pixel aligned right? + bcs SE87B ; brif so + lsrb ; shift right + bra SE875 ; see if it's aligned yet +SE87B jsr LB4F3 ; return colour number + jsr SELTASK0 ; restore memory map + rts +; HLINE command +HLINE tst HRMODE ; is there a graphics mode active? + lbeq SE6EF ; brif not - raise error + lbrn 0 + cmpa #'( ; is there (? + beq SE899 ; brif so - we have start coords + cmpa #0xac ; -? + beq SE899 ; brif no start given + ldb #'@ ; make sure it's @ if not + jsr LB26F +SE899 jsr SE9E1 ; get start/end coords + ldx HOREND ; put end in the defaults + stx HORDEF + ldx VEREND + stx VERDEF + jsr SYNCOMMA ; make sure comma + cmpa #0xbe ; PRESET? + beq SE8B4 ; brif so + cmpa #0xbd ; PSET? + lbne LB277 ; brif not + ldb #1 ; set flag + skip1lda +SE8B4 clrb ; reset flag + pshs b ; save set/reset flag + jsr GETNCH ; eat the PSET/PRESET token + jsr SEA0D ; normalize start/end + puls b ; get back set/reset flag + stb SETFLG ; save set/reset flag + jsr SE731 ; set active colour byte + jsr GETCCH ; is there more? + lbeq SE94E ; brif not - no box + jsr SYNCOMMA ; insist on a comma + ldb #'B ; insist on a B + jsr LB26F + bne SE8EB ; brif something after B + bsr SE906 ; draw horizontal line (top) + bsr SE931 ; draw vertical line (left) + ldx HORBEG ; save horizontal start + pshs x + ldx HOREND ; set up to draw vertical line (right) + stx HORBEG + bsr SE931 ; draw vertical line (right) + puls x ; restore start coord + stx HORBEG + ldx VEREND ; set up to draw horizontal line (bottom) + stx VERBEG + bra SE906 ; draw horizontal line (bottom) and return +SE8EB ldb #'F ; insist on F + jsr LB26F + bra SE8F6 ; draw a filled box +SE8F2 leax -1,x ; move vertical coordinate up one +SE8F4 stx VERBEG ; save new vertical coordinate +SE8F6 jsr SE906 ; draw horizontal line + ldx VERBEG ; get current coordinate + cmpx VEREND ; above or below end? + beq SE905 ; brif done + bhs SE8F2 ; brif below - move up + leax 1,x ; move down (we're above) + bra SE8F4 ; draw another line +SE905 rts +SE906 ldx HORBEG ; get starting coordinate + pshs x ; save it + jsr SE9DB ; get absolute horizontal difference + bcc SE913 ; brif end > start + ldx HOREND ; get ending coordinate + stx HORBEG ; save as starting position +SE913 tfr d,y ; save difference (pixel count) + leay 1,y ; bump it (coords are inclusive) + jsr HCALPOS ; calculate pixel address + puls u ; get start coordinate + stu HORBEG ; restore it + lbsr SEA16 ; point to routine to move pixel pointer right +SE921 sta VD7 ; save pixel mask + jsr SE788 ; turn on pixel + lda VD7 ; get back pixel mask + jsr ,u ; move one pixel right + leay -1,y ; done all pixels? + bne SE921 ; brif not + rts +SE92F puls d ; clean up stack +SE931 ldd VERBEG ; get vertical start + pshs d ; save it + jsr SE9CD ; calculate absolute vertical difference + bcc SE93E ; brif end > start + ldx VEREND ; swap coordinate + stx VERBEG +SE93E tfr d,y ; save difference (pixel count) + leay 1,y ; coordinates are inclusive + jsr HCALPOS ; get screen pointer + puls u ; get original start coord + stu VERBEG ; restore it + lbsr SEA21 ; get routine to move down one row + bra SE921 ; draw vertical line +SE94E ldy #SE9B8 ; point to vertical increment routine + jsr SE9CD ; calculate absolute vertical difference + beq SE906 ; draw horizontal if difference is 0 + bcc SE95D ; brif vertical end > vertical start + ldy #SE9C6 ; point to decrement vertical routine +SE95D pshs b,a ; save vertical difference + ldu #SE9B1 ; point to horitzontal increment routine + jsr SE9DB ; calculate absolute horizontal difference + beq SE92F ; draw vertical line if difference is 0 + bcc SE96C ; brif horizontal end > horizontal start + ldu #SE9BF ; point to decrement horizontal routine +SE96C cmpd ,s ; compare horiztonal difference with vertical difference + puls x ; get vertical difference back + bhs SE977 ; brif horizontal difference is greater + exg u,y ; swap major/minor directions + exg d,x +SE977 pshs u,d ; save larger difference and incr/decr routine + pshs d ; save larger difference + lsra ; divide larger difference by 2 + rorb + bcs SE988 ; brif odd + cmpu #SE9B8+1 ; inc or dec? + blo SE988 ; brif inc + subd #1 ; move back of dec (round down) +SE988 pshs x,d ; save smaller difference and inc/dec + jsr SE7E6 ; point to screen address routine +SE98D jsr ,u ; convert coordinates to screen address + jsr SE788 ; turn on pxiel + ldx 6,s ; done all? + beq SE9AD ; brif so + leax -1,x ; account for pixel just drawn + stx 6,s + jsr [8,s] ; bump coordinate + ldd ,s ; get minor coordinate increment counter + addd 2,s ; add to minor coordinate + std ,s ; save new minor increment + subd 4,s ; subtract largest difference + bcs SE98D ; brif result not bigger than largest difference + std ,s ; save new minor increment + jsr ,y ; inc/dec minor + bra SE98D ; draw another pixel +SE9AD puls x ; clean up stack + puls d,x,y,u,pc ; clean up stack and return +SE9B1 ldx HORBEG ; bump horizontal coord + leax 1,x + stx HORBEG + rts +SE9B8 ldx VERBEG ; bump vertical coord + leax 1,x + stx VERBEG + rts +SE9BF ldx HORBEG ; reduce horizontal coord + leax -1,x + stx HORBEG + rts +SE9C6 ldx VERBEG ; reduce vertical coord + leax -1,x + stx VERBEG +SE9CC rts +SE9CD ldd VEREND ; get vertical end + subd VERBEG ; get subtract start +SE9D1 bcc SE9CC ; brif end > start + pshs cc ; save flag for which is > + nega ; negate difference + negb + sbca #0 + puls cc,pc ; restore status andreturn +SE9DB ldd HOREND ; get horizontal end coord + subd HORBEG ; subtract start coord + bra SE9D1 ; handle going negative +; Evaluate two sets of coordinates +SE9E1 ldx HORDEF ; set start to default + stx HORBEG + ldx VERDEF + stx VERBEG + cmpa #0xac ; -? + beq SE9F0 ; brif so - use default start + jsr SEA04 ; evaluate coordinate pair +SE9F0 ldb #0xac ; insist on - + jsr LB26F + jsr LB26A ; insist on ( + jsr LB734 ; evaluate two expressions (X, B) + ldy #HOREND ; point to end coords + jsr SE7B9 ; validate end coords + bra SEA0A ; handle rest of evaluation +SEA04 jsr LB26A ; insist on ( + jsr SE7B2 ; evaluate coordinates with range check +SEA0A jmp LB267 ; insist on ) +SEA0D jsr SE7AD ; "normalize" start + ldu #HOREND ; point to end coords + jmp SE7B0 ; "normalize" end +; Point U to routine to move pixel to right +SEA16 ldu #SEA25 ; point to jump table + ldb HRMODE ; get graphics mode + subb #1 ; zero-base it + aslb ; two bytes per entry + ldu b,u ; get routine address + rts +SEA21 ldu #SEA45 ; point to routine to move down one row + rts +SEA25 fdb SEA34 ; HSCREEN 1 right + fdb SEA3D ; HSCREEN 2 right + fdb SEA2D ; HSCREEN 3 right + fdb SEA34 ; HSCREEN 4 right +SEA2D lsra ; move pixel mask right + bcc SEA33 ; brif not changing bytes + rora ; shift mask back around to left + leax 1,x ; move byte forward +SEA33 rts +SEA34 lsra ; move one pixel right + lsra + bcc SEA33 ; brif same byte + lda #0xc0 ; reset pixel mask + leax 1,x ; move to next byte + rts +SEA3D coma ; flip pixels + cmpa #0xf0 ; did we move to a new byte? + bne SEA44 ; brif not + leax 1,x ; move to next byte +SEA44 rts +SEA45 ldb HORBYT ; get number of bytes per row + abx ; move ahead that many + rts +; HCIRCLE command +HCIRCLE tst HRMODE ; graphics mode? + lbeq SE6EF ; brif not - raise error + lbrn 0 + cmpa #'@ ; is there @ before coords? + bne SEA59 ; brif not + jsr GETNCH ; eat the @ +SEA59 jsr SEB60 ; get max coords for video mode + jsr SEA04 ; parse centre coords + jsr SE7AD ; normalize coordinates (ha ha) + ldx ,u ; get horizontal coordinate + stx VCB ; save it + ldx 2,u ; get vertical coordinate + stx VCD ; save it + jsr SYNCOMMA ; insist on a comma + jsr LB73D ; evaluate expression into X (radius) + ldu #VCF ; point to temp storage area + stx ,u ; save radius + jsr SE7B0 ; normalize - pointless + lda #1 ; put into "set" mode + sta SETFLG + jsr SE718 ; evaluate colour + ldx #0x100 ; default H/W ratio (1:1) + jsr GETCCH ; is the an HW ratio? + beq SEA95 ; brif not + jsr SYNCOMMA ; insist on comma + jsr LB141 ; evaluate HW ratio + lda FP0EXP ; multiply by 256 + adda #8 + sta FP0EXP + jsr LB740 ; fetch HW ratio to X (with a fixed 8 bit fraction part) +SEA95 lda HRMODE ; get graphics mode + cmpa #2 ; is it a 320 mode? + bhi SEA9F ; brif not + tfr x,d ; double HW ratio for 320 modes + leax d,x +SEA9F stx VD1 ; save H/W ratio + ldb #1 ; go into SET mode + stb SETFLG + stb VD8 ; flag for "first arc" + jsr SEB7B ; evaluate start point (octant, subarc) + pshs d ; save start point + jsr SEB7B ; evaluate end point + std VD9 ; save end point + puls d ; get back start point +SEAB3 pshs d ; save current circle position + ldx HOREND ; switch previous end coords in as the start + stx HORBEG + ldx VEREND + stx VERBEG + ldu #CIRCDATA+2 ; point to sines/cosines table + anda #1 ; is it an even octant? + beq SEAC7 ; brif so + negb ; swap arc order for odd octants + addb #8 +SEAC7 aslb ; four bytes per table entry + aslb + leau b,u ; now U points to the correct entry + pshs u ; save table entry + jsr SEBBD ; calculate horizontal offset + puls u ; get back table pointer + leau -2,u ; move to other entry + pshs x ; save horizontal offset + jsr SEBBD ; calculaute vertical offset + puls y ; get back horizontal offset + lda ,s ; get octant number + anda #3 ; is it 0 or 4? + beq SEAE7 ; brif so + cmpa #3 ; is it 3 or 7? + beq SEAE7 ; brif so + exg x,y ; swap horizontal and vertical otherwise +SEAE7 stx HOREND ; save horizontal offset + tfr y,d ; divide offset by 2 + lsra + rorb + ldx VD1 ; get H/W ratio + jsr SEBCB ; multiply offset by ratio + tfr y,d ; did MSB (bits 23-16) end up nonzero? + tsta ; brif so - outside 16 bit range + lbne LB44A ; brif so - raise error + stb VEREND ; save vertical offset MSB + tfr u,d ; get low bytes of result + sta VEREND+1 ; save LSB (lose fractional part) + lda ,s ; get octant number + cmpa #2 ; 0 or 1? + blo SEB13 ; brif so + cmpa #6 ; 6 or h? + bhs SEB13 ; brif so + ldd VCB ; get horizontal center + subd HOREND ; subtract offset (going left) + bcc SEB20 ; brif we didn't go negative + clra ; minimize to 0 + clrb + bra SEB20 +SEB13 ldd VCB ; get horizontal centre + addd HOREND ; add offset + bcs SEB1E ; brif we overflowed + cmpd VD3 ; did we overflow screen size? + blo SEB20 ; brif not +SEB1E ldd VD3 ; maximize horizontal coordinate +SEB20 std HOREND ; save new horizontal coordinate + lda ,s ; get octantnumber + cmpa #4 ; is it 0-3 (bottom half)? + blo SEB32 ; brif so + ldd VCD ; get vertical centre + subd VEREND ; subtract offset + bcc SEB3F ; brif we didn't run past 0 + clra ; minimize to 0 + clrb + bra SEB3F +SEB32 ldd VCD ; get vertical centre + addd VEREND ; add offset + bcs SEB3D ; brif we overflowed + cmpd VD5 ; did we go past end of screen? + blo SEB3F ; brif not +SEB3D ldd VD5 ; maximize to screen size +SEB3F std VEREND ; save new vertical coord + tst VD8 ; was this the first coordinate? + bne SEB48 ; brif so - don't draw a line + lbsr SE94E ; draw the subarc line +SEB48 puls d ; get octant and arc + lsr VD8 ; test if first point, and clear flag + bcs SEB53 ; brif first coord + cmpd VD9 ; at end of circle? + beq SEB5F ; brif so +SEB53 incb ; bump arc counter + cmpb #8 ; done 8 subarcs? + bne SEB5C ; brif not + inca ; bump octant + clrb ; reset arc counter + anda #7 ; wrap octant number if needed +SEB5C jmp SEAB3 ; move on with the next arc +SEB5F rts +SEB60 ldu #VD3 ; point to storage area + ldx #639 ; set max horizontal coord for 640 mode + stx ,u + lda HRMODE ; get graphics mode + cmpa #2 ; is it a 640 mode? + bgt SEB73 ; brif so + ldx #319 ; set max horzontalcoord for 320 mode + stx ,u +SEB73 ldx #191 ; all modes have a 191 vertical max + stx 2,u + jmp SE7B0 ; "normalize" coords +SEB7B clrb ; default circle start/end to 0 + jsr GETCCH ; is there a fraction? + beq SEB91 ; brif not + jsr SYNCOMMA ; insist on a comma + jsr LB141 ; evaluate circle fraction + lda FP0EXP ; multiply by 64 (calculate # of 64ths) + adda #6 + sta FP0EXP + jsr LB70E ; fetch result as 8 bits unsigned + andb #0x3f ; keep only the fraction part +SEB91 tfr b,a ; copy fraction to A (for octant) + andb #7 ; keep only arc number in B + lsra ; shift octant number to right of A + lsra + lsra + rts +CIRCDATA fdb 0x0000,0x0001 ; subarc 0 + fdb 0xfec5,0x1919 ; subarc 1 + fdb 0xfb16,0x31f2 ; subarc 2 + fdb 0xf4fb,0x4a51 ; subarc 3 + fdb 0xec84,0x61f9 ; subarc 4 + fdb 0xe1c7,0x78ae ; subarc 5 + fdb 0xd4dc,0x8e3b ; subarc 6 + fdb 0xc5e5,0xa269 ; subarc 7 + fdb 0xb506,0xb506 ; subarc 8 +SEBBD ldx VCF ; get radius + ldd ,u ; get sin/cos value + beq SEBCA ; brif 0 - just use radius + subd #1 ; subtract 1 + bsr SEBCB ; do the multiplication dance + tfr y,x ; save result to X +SEBCA rts +SEBCB pshs u,y,x,b,a ; save registers and reserve storage + clr 4,s ; clear high bits + lda 3,s ; B*XL + mul + std 6,s ; save in partical result + ldd 1,s ; A*XH + mul + addb 6,s ; add to partial product + adca #0 + std 5,s + ldb ,s ; A*XL + lda 3,s + mul + addd 5,s ; add to partial product + std 5,s + bcc SEBEA + inc 4,s +SEBEA lda ,s ; A*XH + ldb 2,s + mul + addd 4,s ; add to partial product + std 4,s ; save final product bits + puls a,b,x,y,u,pc ; save factors, retrieve result, and return +; HPAINT command +HPAINT tst HRMODE ; do we have a grahpics mode? + lbeq SE6EF ; brif not - raise error + lbrn 0 + cmpa #'@ ; is there @ before the coords? + bne SEC05 ; brif not + jsr GETNCH ; eat the @ +SEC05 jsr SEA04 ; insist on ( + jsr SE7AD ; evaluate the coordinates + lda #1 ; set up for "setting" + sta SETFLG + jsr SE718 ; evaluate colour code + ldd WCOLOR ; get working colour and all pixels byte + pshs d ; save them for later + jsr GETCCH ; do we have a border colour? + beq SEC1D ; brif not - use default + jsr SE718 ; evaluate border colour +SEC1D lda ALLCOL ; get border colour pixel byte + sta VD8 ; save it + puls d ; get paint colour details + std WCOLOR ; restore them + jsr SELTASK1 ; map the graphics screen + clra ;* add a terminator block to the top of the stack + pshs u,x,b,a ;* which is how HPAINT knows it's done + jsr SEB60 ; get maximum coordinate values + jsr SE7E6 ; point U to routine that selects a pixel + stu VD9 ; save pixel selection routine address + jsr SECBE ; paint from current coord to the left + beq SEC47 ; brif no painting done - we started on the border + jsr SED01 ; paint to the right + lda #1 ; set up a record to paint down the screen + sta VD7 + jsr SED2E + neg VD7 ; set up a record to paint up the screen + jsr SED2E +SEC47 sts TMPSTK ; save stack pointer +SEC4A tst CHGFLG ; see if a pixel changed + bne SEC51 ; brif so + lds TMPSTK ; get stack pointer back +SEC51 puls a,b,x,u ; get data for the next line to handle + clr CHGFLG ; flag nothing changed yet + sts TMPSTK ; save new stack address + leax 1,x ; add one to the start position + STX HORBEG ; set it as the starting position + stu VD1 ; save length of parent line + sta VD7 ; save up/down flag + beq SECBA ; brif up/down is 0 - end marker + bmi SEC6A ; brif we're going up the screen + incb ; bump vertical coord + cmpb VD6 ; at end of screen? + bls SEC6E ; brif not + clrb ; wrap around - this will cause us to bail below +SEC6A tstb ; is coord 0? + beq SEC4A ; brif so - don't go upward + decb ; move upward on the screen +SEC6E stb VERBEG+1 ; save new vertical coordinate + jsr SECBE ; paint to the left + beq SEC86 ; brif no pixels changed + cmpd #3 ; less than 3 painted? + blo SEC80 ; brif so - no need to check for paintable data + leax -2,x ; move coord left two + jsr SED15 ; save block of paint data in the other direction (vertically) +SEC80 jsr SED01 ; paint to the right +SEC83 jsr SED2E ; save a block of paint data in the same direction +SEC86 coma ; invert number of pixels painted (but "less 1") + comb +SEC88 addd VD1 ; add to length of parent line + std VD1 ; now we have the new parent line length + ble SECA5 ; brif parent line was shorter + jsr SE9B1 ; bump horizontal + jsr SECF1 ; check for border + bne SEC9B ; brif not + ldd #-1 ; count down + bra SEC88 ; keep looking +SEC9B jsr SE9BF ; move left + jsr SED3A ; save horizontal coord + bsr SECC7 ; paint to the right + bra SEC83 ; save paint block and keep going +SECA5 jsr SE9B1 ; bump horizontal coord + leax d,x ; point to right of end of parent line + stx HORBEG ; set as start coord + coma ; negate pixel count (and subtract 2?) + comb + subd #1 + ble SECB7 ; brif line doesn't extend past right of parent + tfr d,x ; save portion of line to the right as length + bsr SED15 ; save block of paint data +SECB7 jmp SEC4A ; go process more paint blocks +SECBA jsr SELTASK0 ; unmap screen + rts +SECBE jsr SED3A ; point starting coord in end + ldy #SE9BF ; point to dec horizontal + bra SECCD ; paint line +SECC7 ldy #SE9B1 ; point to incr horizontal coord + jsr ,y ; skip first - already done +SECCD ldu ZERO ; initial pixel counter to 0 + ldx HORBEG ; get starting coord +SECD1 bmi SECEA ; brif off the left side + cmpx VD3 ; at max value? + bhi SECEA ; brif off right side + pshs u,y ; save counter and inc/dec p ointer + bsr SECF1 ; check for border + beq SECE8 ; brif so - we're done + jsr SE792 ; set pixel + puls y,u ; restore count and inc/dec routine + leau 1,u ; bump count + jsr ,y ; adjust coord + bra SECD1 ; go do another pixel +SECE8 puls y,u ; get back counter and inc/dec pointer +SECEA tfr u,d ; save paint counter in D and X + tfr d,x + subd ZERO ; set flags on counter + rts +SECF1 jsr [VD9] ; get address of pixel + tfr a,b ; duplicate mask + andb VD8 ; get pixel colour mask for the pixel + pshs b,a ; save masks + anda ,x ; merge in with pixel data on screen + cmpa 1,s ; does it match? (Z set if so) + puls a,b,pc ; restore masks and return +SED01 std VCD ; save pixel count + ldy HOREND ; get last horizontal coord + bsr SED3A ; save current coord + sty HORBEG ; start painting to right from the previous end + bsr SECC7 ; go paint rightward + ldx VCD ; get previous pixel count + leax d,x ; now we have a total count for this line + addd #1 ; bump it by one? + rts +SED15 std VCB ; save painted pixel count + puls y ; get return address + ldd HORBEG ; get start coord + pshs x,d ; save start coord and line length + lda VD7 ; get direction + nega ; invert it +SED20 ldb VERBEG+1 ; get vertical coordinate + pshs b,a ; save direction and vertical coord + pshs y ; put return address back + ldb #6 ; make sure we didn't overflow the stack + jsr SED3F + ldd VCB ; get line length back + rts +SED2E std VCB ; save line length + puls y ; get return address + ldd HOREND ; get horizontal start + pshs x,d ; save line length and horizontal coord + lda VD7 ; get direction flag + bra SED20 ; finish saving frame +SED3A ldx HORBEG ; get start coord + stx HOREND ; save it as end coord + rts +SED3F negb ; subtract B bytes from S + leas b,s + cmps #TMPSTACK-(0x2000+14) ; does it overflow? (14 extra is from the unused vectors at the top of the CB ROM area) + lblo SED4E ; raise OM error if we did + negb ; restore stack pointer + leas b,s + rts +SED4E lds #TMPSTACK-2 ; reset stack (since we overflowed it) + jsr SELTASK0 ; restore default memory map + jmp LAC44 ; raise OM error +; HBUFF command +HBUFF jsr LB73D ; evaluate buffer number to X + lbrn 0 + cmpx #255 ; valid? + lbhi LB44A ; brif not + stx VD1 ; save buffer number + beq SED72 ; don't get size if buffer 0 select + jsr SYNCOMMA ; insist on a comma + jsr LB73D ; evaluate size to X + stx VD3 ; save buffer size +SED72 jsr SE0CB ; map the buffers + jsr SELTASK1 + ldd VD1 ; get buffer number + tstb ; is it zero (not needed!) + bne SED85 ; brif not + ldd #0xffff ; clear all buffers + std HRESBUFF + bra SEDBD ; reset memory map and return +SED85 ldy #HRESBUFF ; point to buffers + ldd ,y ; get address of next block + cmpd #0xffff ; empty buffer space? + bne SED95 ; brif not + bsr SEDC4 ; check for room in buffer space + bra SEDB0 ; set up buffer +SED95 ldb VD1+1 ; get buffer number +SED97 cmpb 2,y ; is this buffer the same number? + beq SEDD2 ; brif so - throw error + ldu ,y ; get address of next buffer + beq SEDA3 ; brif last buffer + tfr u,y ; move on to next buffer + bra SED97 ; see if we have a matching number here +SEDA3 tfr y,u ; save start address to U + ldd 3,y ; get size of last buffer + leay 5,y ; move past header + leay d,y ; move past buffer data + bsr SEDC4 ; check for enough room + sty ,u ; save pointer to the new buffer in previous header +SEDB0 ldd #0 ; mark this as the last buffer + std ,y + ldb VD1+1 ; set buffer number + stb 2,y + ldd VD3 ; set buffer size + std 3,y +SEDBD jsr SELTASK0 ; restore memory map + jsr SETMMU + rts +SEDC4 tfr y,x ; point X to the start of the buffer data + leax 5,x + ldd VD3 ; get length requested + leax d,x ; point to end of new buffer + cmpx #HRESBUFF+0x1f00 ; does it fit? + bhi SEDD6 ; brif not + rts +SEDD2 ldb #9*2 ; code for redim array + bra SEDD8 +SEDD6 ldb #6*2 ; code for out of memory +SEDD8 lds #TMPSTACK-2 ; reset stack + jsr SELTASK0 ; restore memory map + jsr SETMMU + jmp LAC46 ; raise error +; HGET command +HGET ldx #SEEC0 ; point to HGET movement routine + stx VD5 ; save it + clrb ; flag for "GET" + bra SEDF4 ; get on with things +; HPUT command +HPUT ldx #SEEEF ; point to HPUT movement routine + stx VD5 ; save it + ldb #1 ; flag for "PUT" +SEDF4 tst HRMODE ; check for graphics + lbeq SE6EF ; brif not - raise error + lbrn 0 + stb VD8 ; save GET/PUT flag + cmpa #'@ ; is there @ before coords? + bne SEE06 ; brif not + jsr GETNCH ; eat the @ +SEE06 jsr SE9E1 ; evaluate box bounds + jsr SYNCOMMA ; insist on a comma + jsr EVALEXPB ; evaluate buffer number + stb VD3 ; save buffer number + clr VD4 ; default action to none + jsr GETCCH ; is there an action flag? + beq SEE38 ; brif not + com VD4 ; flag for action flag specified + jsr SYNCOMMA ; insist on a comma + tst VD8 ; is it GET? + bne SEE23 ; brif not + lbra LB277 ; raise error +SEE23 ldb #5 ; 5 possible actions + ldx #SEEE0 ; point to action routine table address +SEE28 ldu ,x++ ; get routine address + cmpa ,x+ ; does the action match? + beq SEE34 ; brif so + decb ; checked all of them? + bne SEE28 ; brif not + jmp LB277 ; raise error +SEE34 stu VD5 ; save action address + jsr GETNCH ; eat the action token +SEE38 jsr SE0CB ; map the buffers and screen + jsr SELTASK1 + ldb VD3 ; get buffer number + jsr SEF18 ; find the correct buffer's data + ldd HORBEG ; get horizontal start + cmpd HOREND ; is it less than end? + ble SEE50 ; brif so + ldx HOREND ; swap start/end horizontal coords + stx HORBEG + std HOREND +SEE50 ldd VERBEG ; get vertical start + cmpd VEREND ; less that end? + ble SEE5D ; brif so + ldx VEREND ; swap vertical coords + stx VERBEG + std VEREND +SEE5D lda HRMODE ; get graphics mode + ldb #0xf8 ; round off mask for mode 3 (1 bpp) + cmpa #3 ; is it mode 3 (1 bpp) + beq SEE6D ; brif so + ldb #0xfc ; mask for mode 1 or 4 (2 bpp) + cmpa #2 ; is it mode 2? + bne SEE6D ; brif not - it's mode 1 or 4 + ldb #0xfe ; round off mask for mode 2 (4 bpp) +SEE6D tfr b,a ; save round off in A and B - we need it twice + anda HORBEG+1 ; round off horizontal start + sta HORBEG+1 + andb HOREND+1 ; round of horizontal end coord + stb HOREND+1 + jsr SE9DB ; calculate horizontal difference + std HOREND ; save it + jsr SE9CD ; calculate vertial difference + addd #1 ; make it inclusive + std VEREND ; save it + lda HRMODE ; get graphics mode + cmpa #2 ; HSCREEN 2? + beq SEE96 ; divide pixel count by 2 for byte count + cmpa #3 ; HSCREEN 3? + bne SEE92 ; brif not - divide by 4 (HSCREEN 1, 4) + lsr HOREND ; divide by 8 (falls through to by 4) + ror HOREND+1 +SEE92 lsr HOREND ; divide by 4 (falls through to divide by 2) + ror HOREND+1 +SEE96 lsr HOREND ; divide by 2 + ror HOREND+1 + ldd HOREND ; get byte count + addd #1 ; make it inclusive of the end + std HOREND + jsr HCALPOS ; get pointer to screen location + ldy VD5 ; point to action routine address +SEEA7 ldb HOREND+1 ; get LS byte of byte count + pshs x ; save line start pointer +SEEAB jsr ,y ; perform movement action + decb ; done all bytes? + bne SEEAB ; brif not + puls x ; get back line start + jsr SEA45 ; move down one line + dec VEREND+1 ; done all rows? + bne SEEA7 ; brif not + jsr SELTASK0 ; restore memory map + jsr SETMMU + rts +SEEC0 lda ,x+ ; get a byte from screen + bsr SEEC7 ; point to proper buffer location + sta ,u ; save it + rts +SEEC7 ldu VCF ; get buffer pointer + leau 1,u ; move to next byte + stu VCF ; save new pointer + cmpu VD1 ; did we run past the end of the buffer? + bhi SEED3 ; brif so - raise error + rts +SEED3 lds #TMPSTACK-2 ; reset stack + jsr SELTASK0 ; restore memory map + jsr SETMMU + jmp LB44A ; raise FC error +SEEE0 fdb SEEEF ; PSET action routine + fcb 0xbd ; PSET token + fdb SEEF6 ; PRESET action routine + fcb 0xbe ; PRESET token + fdb SEF07 ; OR action routine + fcb 0xb1 ; OR token + fdb SEEFE ; AND action routine + fcb 0xb0 ; AND token + fdb SEF10 ; NOT action routine + fcb 0xa8 ; NOT token +SEEEF bsr SEEC7 ; point to buffer location + lda ,u ; get byte from buffer + sta ,x+ ; put it on screen + rts +SEEF6 bsr SEEC7 ; point to buffer location + lda ,u ; get byte + coma ; invert it + sta ,x+ ; put it on screen + rts +SEEFE bsr SEEC7 ; point to buffer location + lda ,u ; get byte from buffer + anda ,x ; "AND" with screen data + sta ,x+ ; put it on screen + rts +SEF07 bsr SEEC7 ; point to buffer location + lda ,u ; get byte from buffer + ora ,x ; "OR" with screen data + sta ,x+ ; put on screen + rts +SEF10 bsr SEEC7 ; point to buffer address + lda ,x ; get byte from screen (BUG: should be ,u to get from buffer) + coma ; invert data + sta ,x+ ; save on screen + rts +SEF18 ldy #HRESBUFF ; point to start of buffers + lda ,y ; are there any buffers? + cmpa #0xff + bne SEF2C ; brif so + jmp SEED3 ; raise error if no buffers +SEF25 ldy ,y ; point to next buffer + lbeq SEED3 ; brif end of buffers - raise error +SEF2C cmpb 2,y ; is this the desired buffer? + bne SEF25 ; brif not + ldd 3,y ; get size of buffer + leay 4,y ; point to start of data (less one for "pre-inc" on use + sty VCF ; save buffer pointer + leay 1,y ; point to actual data start + leay d,y ; calculate address of end of buffer + sty VD1 ; save end address + rts +; HPRINT command +HPRINT tst HRMODE ; graphics mode? + lbeq SE6EF ; brif not - raise error + lbrn 0 + jsr LB26A ; insist on ( + jsr SE7B2 ; evaluate coordinates + jsr LB267 ; insist on ) + jsr SYNCOMMA ; insist on comma + jsr LB156 ; evaluate print string + tst VALTYP ; is it string? + bne SEF62 ; brif not numeric (should be BMI) + jsr LBDD9 ; convert number to string + jsr LB516 ; save string in string space and all that jazz +SEF62 jsr LB657 ; fetch string details + stb H.PCOUNT ; save length in print count + ldy #H.PBUF ; point to temporary string buffer +SEF6C decb ; have we processed the whole string? + bmi SEF75 ; brif so (or if the string length was > 128) + lda ,x+ ; copy a character from the string into the buffer + sta ,y+ + bra SEF6C ; see if we're done yet +SEF75 lda HRMODE ; get graphics mode + ldb #40 ; 40 characters on a 320 line + cmpa #3 ; is it mode 1 or 2? + blo SEF7F ; brif so + ldb #80 ; 80 characters on a 640 line +SEF7F clra ; zero extend line size + subd HORBEG ; subtract first position from line length + bmi SF001 ; brif we're printing off the side of the screen + cmpb H.PCOUNT ; is the print count larger than characters left? + bhi SEF8E ; brif not + stb H.PCOUNT ; save remaining screen positions as print count + beq SF001 ; brif nothing to print +SEF8E lda #ROWMAX-1 ; get highest row number + cmpa VERBEG+1 ; are we in range? + bge SEF96 ; brif so + sta VERBEG+1 ; force bottom row if not in range +SEF96 jsr SF08C ; calculate actual pixel coordinates + jsr HCALPOS ; get screen pointer + ldy #H.PBUF ; point to string data + ldb H.PCOUNT ; get number of characters to print +SEFA3 lda ,y ; get character to print + anda #0x7f ; lose bit 7 (character set repeats) + suba #0x20 ; lose the "control" characters - no glyphs for those codes + bpl SEFAD ; brif it was not a control character + lda #0 ; use a space if it was +SEFAD sta ,y+ ; put glyph number into the buffer + decb ; processed all of them? + bgt SEFA3 ; brif not + lda HRMODE ; get graphics mode + deca ; zero-base it + asla ; two bytes per display routine + ldy #SF002 ; point to display routine table + ldy a,y ; point to display routine + sty VD1 ; save it + lda #8 ; 8 rows per character + sta VD3 ; temp save row counter + ldy #H.PBUF ; point to print buffer + ldu #SF09D ; point to FONT data + ldb H.FCOLOR ; get foreground colour + jsr PIXELFIL ; get an all pixel byte + stb ALLCOL ; save it + jsr SELTASK1 ; map the screen + lda H.PCOUNT ; get character count to display +SEFD9 pshs y,x,a ; save buffer pointer, character count, and screen address +SEFDB ldb ,y+ ; get character from buffer + clra ; zero extend it + aslb ;* 8 bytes per character entry (don't need rola after first + aslb ;* because characters are only 7 bits + rola + aslb + rola + lda d,u ; get font data for this row + jsr [VD1] ; display it + dec H.PCOUNT ; done all characters on this row? + bgt SEFDB ; brif not + puls a,x,y ; get back character count, buffer pointer, and screen address + dec VD3 ; have we done all the rows? + beq SEFFE ; brif so + sta H.PCOUNT ; restore print count + leau 1,u ; move one row down the font data + jsr SEA45 ; move one row down the screen + bra SEFD9 ; go do another row of pixels +SEFFE jsr SELTASK0 ; restore memory map +SF001 rts +SF002 fdb SF01A ; HSCREEN 1 (2 bpp) + fdb SF045 ; HSCREEN 2 (4 bpp) + fdb SF00A ; HSCREEN 3 (1 bpp) + fdb SF01A ; HSCREEN 4 (2 bpp) +SF00A pshs a ; save font data + coma ; invert it + anda ,x ; merge with screen - turns off pixels in the character + sta ,x ; save it back on the screen + puls a ; get back font data + anda ALLCOL ; merge with colour data + ora ,x ; merge with screen to fill hole created above + sta ,x+ ; save it on screen + rts +SF01A pshs y ; save buffer pointer + ldy #SF035 ; point to 2 bpp pixel masks + tfr a,b ; copy character data (need two bytes per character) + lsra ; use the upper 4 bits in first byte + lsra + lsra + lsra + lda a,y ; get pixel mask for all 16 possibilities for upper 4 bits + jsr SF00A ; shove it on screen + andb #0x0f ; lose upper bits for low half + lda b,y ; get pixel mask for this pixel combination + jsr SF00A ; shove that on screen too + puls y ; restore buffer pointer + rts +SF035 fcb 0x00,0x03,0x0c,0x0f ; combined pixel masks for 16 possibilities for a 2 bpp byte + fcb 0x30,0x33,0x3c,0x3f + fcb 0xc0,0xc3,0xcc,0xcf + fcb 0xf0,0xf3,0xfc,0xff +SF045 pshs y,a ; save buffer pointer and font data + ldy #SF06C ; point to 16 colour masks + lsra ; fetch high 4 bits + lsra + lsra + lsra + asla ; two bytes per mask (this is NOT redundant - this and above clears bit 0) + ldd a,y ; get two byte mask for these four bits + jsr SF00A ; show upper 2 pixels + tfr b,a ; show lower 2 pixels + jsr SF00A + puls a ; get back font data + anda #0x0f ; lost upper bits + asla ; two bytes per mask + ldd a,y ; get mask data + jsr SF00A ; show upper 2 pixels + tfr b,a ; show lower 2 pixels + jsr SF00A + puls y ; restore buffer pointer + rts +SF06C fdb 0x0000,0x000f,0x00f0,0x00ff ; combined pixel masks for 16 possibilities for a 4 bpp double byte + fdb 0x0f00,0x0f0f,0x0ff0,0x0fff + fdb 0xf000,0xf00f,0xf0f0,0xf0ff + fdb 0xff00,0xff0f,0xfff0,0xffff +SF08C ldd HORBEG ; get horizontal character cell coordinate + aslb ; times 8 - 8x8 font data; note first shift can't cause carry with max 79 for column number + aslb + rola + aslb + rola + std HORBEG ; save actual horizontal pixel position of print position + lda VERBEG+1 ; get vertical character cell coordinate + asla ; times 8 - 8x8 font data + asla + asla + sta VERBEG+1 ; save actual vertical pixel position of print position + rts +; This is the HPRINT font, which is basically equivalent to the hardware font in the GIME for character codes +; 0x20 through 0x7f. It does not include the extra characters in the 0x00-0x1f range of the hardware character +; set. However, glyphs for those are actually included in the ROM above the end of the actual code. +SF09D fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 ; SPACE + fcb 0x10,0x10,0x10,0x10,0x10,0x00,0x10,0x00 ; ! + fcb 0x28,0x28,0x28,0x00,0x00,0x00,0x00,0x00 ; " + fcb 0x28,0x28,0x7C,0x28,0x7C,0x28,0x28,0x00 ; # + fcb 0x10,0x3C,0x50,0x38,0x14,0x78,0x10,0x00 ; $ + fcb 0x60,0x64,0x08,0x10,0x20,0x4C,0x0C,0x00 ; % + fcb 0x20,0x50,0x50,0x20,0x54,0x48,0x34,0x00 ; & + fcb 0x10,0x10,0x20,0x00,0x00,0x00,0x00,0x00 ; ' + fcb 0x08,0x10,0x20,0x20,0x20,0x10,0x08,0x00 ; ( + fcb 0x20,0x10,0x08,0x08,0x08,0x10,0x20,0x00 ; ) + fcb 0x00,0x10,0x54,0x38,0x38,0x54,0x10,0x00 ; * + fcb 0x00,0x10,0x10,0x7C,0x10,0x10,0x00,0x00 ; + + fcb 0x00,0x00,0x00,0x00,0x00,0x10,0x10,0x20 ; , + fcb 0x00,0x00,0x00,0x7C,0x00,0x00,0x00,0x00 ; - + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x10,0x00 ; . + fcb 0x00,0x04,0x08,0x10,0x20,0x40,0x00,0x00 ; / + fcb 0x38,0x44,0x4C,0x54,0x64,0x44,0x38,0x00 ; 0 + fcb 0x10,0x30,0x10,0x10,0x10,0x10,0x38,0x00 ; 1 + fcb 0x38,0x44,0x04,0x38,0x40,0x40,0x7C,0x00 ; 2 + fcb 0x38,0x44,0x04,0x08,0x04,0x44,0x38,0x00 ; 3 + fcb 0x08,0x18,0x28,0x48,0x7C,0x08,0x08,0x00 ; 4 + fcb 0x7C,0x40,0x78,0x04,0x04,0x44,0x38,0x00 ; 5 + fcb 0x38,0x40,0x40,0x78,0x44,0x44,0x38,0x00 ; 6 + fcb 0x7C,0x04,0x08,0x10,0x20,0x40,0x40,0x00 ; 7 + fcb 0x38,0x44,0x44,0x38,0x44,0x44,0x38,0x00 ; 8 + fcb 0x38,0x44,0x44,0x38,0x04,0x04,0x38,0x00 ; 9 + fcb 0x00,0x00,0x10,0x00,0x00,0x10,0x00,0x00 ; : + fcb 0x00,0x00,0x10,0x00,0x00,0x10,0x10,0x20 ; ; + fcb 0x08,0x10,0x20,0x40,0x20,0x10,0x08,0x00 ; < + fcb 0x00,0x00,0x7C,0x00,0x7C,0x00,0x00,0x00 ; = + fcb 0x20,0x10,0x08,0x04,0x08,0x10,0x20,0x00 ; > + fcb 0x38,0x44,0x04,0x08,0x10,0x00,0x10,0x00 ; ? + fcb 0x38,0x44,0x04,0x34,0x4C,0x4C,0x38,0x00 ; @ + fcb 0x10,0x28,0x44,0x44,0x7C,0x44,0x44,0x00 ; A + fcb 0x78,0x24,0x24,0x38,0x24,0x24,0x78,0x00 ; B + fcb 0x38,0x44,0x40,0x40,0x40,0x44,0x38,0x00 ; C + fcb 0x78,0x24,0x24,0x24,0x24,0x24,0x78,0x00 ; D + fcb 0x7C,0x40,0x40,0x70,0x40,0x40,0x7C,0x00 ; E + fcb 0x7C,0x40,0x40,0x70,0x40,0x40,0x40,0x00 ; F + fcb 0x38,0x44,0x40,0x40,0x4C,0x44,0x38,0x00 ; G + fcb 0x44,0x44,0x44,0x7C,0x44,0x44,0x44,0x00 ; H + fcb 0x38,0x10,0x10,0x10,0x10,0x10,0x38,0x00 ; I + fcb 0x04,0x04,0x04,0x04,0x04,0x44,0x38,0x00 ; J + fcb 0x44,0x48,0x50,0x60,0x50,0x48,0x44,0x00 ; K + fcb 0x40,0x40,0x40,0x40,0x40,0x40,0x7C,0x00 ; L + fcb 0x44,0x6C,0x54,0x54,0x44,0x44,0x44,0x00 ; M + fcb 0x44,0x44,0x64,0x54,0x4C,0x44,0x44,0x00 ; N + fcb 0x38,0x44,0x44,0x44,0x44,0x44,0x38,0x00 ; O + fcb 0x78,0x44,0x44,0x78,0x40,0x40,0x40,0x00 ; P + fcb 0x38,0x44,0x44,0x44,0x54,0x48,0x34,0x00 ; Q + fcb 0x78,0x44,0x44,0x78,0x50,0x48,0x44,0x00 ; R + fcb 0x38,0x44,0x40,0x38,0x04,0x44,0x38,0x00 ; S + fcb 0x7C,0x10,0x10,0x10,0x10,0x10,0x10,0x00 ; T + fcb 0x44,0x44,0x44,0x44,0x44,0x44,0x38,0x00 ; U + fcb 0x44,0x44,0x44,0x28,0x28,0x10,0x10,0x00 ; V + fcb 0x44,0x44,0x44,0x44,0x54,0x6C,0x44,0x00 ; W + fcb 0x44,0x44,0x28,0x10,0x28,0x44,0x44,0x00 ; X + fcb 0x44,0x44,0x28,0x10,0x10,0x10,0x10,0x00 ; Y + fcb 0x7C,0x04,0x08,0x10,0x20,0x40,0x7C,0x00 ; Z + fcb 0x38,0x20,0x20,0x20,0x20,0x20,0x38,0x00 ; ] + fcb 0x00,0x40,0x20,0x10,0x08,0x04,0x00,0x00 ; \ + fcb 0x38,0x08,0x08,0x08,0x08,0x08,0x38,0x00 ; [ + fcb 0x10,0x38,0x54,0x10,0x10,0x10,0x10,0x00 ; UP ARROW + fcb 0x00,0x10,0x20,0x7C,0x20,0x10,0x00,0x00 ; LEFT ARROW + fcb 0x10,0x28,0x44,0x00,0x00,0x00,0x00,0x00 ; ^ + fcb 0x00,0x00,0x38,0x04,0x3C,0x44,0x3C,0x00 ; a + fcb 0x40,0x40,0x58,0x64,0x44,0x64,0x58,0x00 ; b + fcb 0x00,0x00,0x38,0x44,0x40,0x44,0x38,0x00 ; c + fcb 0x04,0x04,0x34,0x4C,0x44,0x4C,0x34,0x00 ; d + fcb 0x00,0x00,0x38,0x44,0x7C,0x40,0x38,0x00 ; e + fcb 0x08,0x14,0x10,0x38,0x10,0x10,0x10,0x00 ; f + fcb 0x00,0x00,0x34,0x4C,0x4C,0x34,0x04,0x38 ; g + fcb 0x40,0x40,0x58,0x64,0x44,0x44,0x44,0x00 ; h + fcb 0x00,0x10,0x00,0x30,0x10,0x10,0x38,0x00 ; i + fcb 0x00,0x04,0x00,0x04,0x04,0x04,0x44,0x38 ; j + fcb 0x40,0x40,0x48,0x50,0x60,0x50,0x48,0x00 ; k + fcb 0x30,0x10,0x10,0x10,0x10,0x10,0x38,0x00 ; l + fcb 0x00,0x00,0x68,0x54,0x54,0x54,0x54,0x00 ; m + fcb 0x00,0x00,0x58,0x64,0x44,0x44,0x44,0x00 ; n + fcb 0x00,0x00,0x38,0x44,0x44,0x44,0x38,0x00 ; o + fcb 0x00,0x00,0x78,0x44,0x44,0x78,0x40,0x40 ; p + fcb 0x00,0x00,0x3C,0x44,0x44,0x3C,0x04,0x04 ; q + fcb 0x00,0x00,0x58,0x64,0x40,0x40,0x40,0x00 ; r + fcb 0x00,0x00,0x3C,0x40,0x38,0x04,0x78,0x00 ; s + fcb 0x20,0x20,0x70,0x20,0x20,0x24,0x18,0x00 ; t + fcb 0x00,0x00,0x44,0x44,0x44,0x4C,0x34,0x00 ; u + fcb 0x00,0x00,0x44,0x44,0x44,0x28,0x10,0x00 ; v + fcb 0x00,0x00,0x44,0x54,0x54,0x28,0x28,0x00 ; w + fcb 0x00,0x00,0x44,0x28,0x10,0x28,0x44,0x00 ; x + fcb 0x00,0x00,0x44,0x44,0x44,0x3C,0x04,0x38 ; y + fcb 0x00,0x00,0x7C,0x08,0x10,0x20,0x7C,0x00 ; z + fcb 0x08,0x10,0x10,0x20,0x10,0x10,0x08,0x00 ; { + fcb 0x10,0x10,0x10,0x00,0x10,0x10,0x10,0x00 ; | + fcb 0x20,0x10,0x10,0x08,0x10,0x10,0x20,0x00 ; } + fcb 0x20,0x54,0x08,0x00,0x00,0x00,0x00,0x00 ; ~ + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x7C,0x00 ; _ +; HDRAW command +HDRAW tst HRMODE ; grahics mode? + lbeq SE6EF ; brif not + lbrn 0 + ldx #0 ; set empty string for "end of DRAW" + ldb #1 + pshs x,b + stb SETFLG ; set up for "set" mode + stx VD5 ; clear update and draw flags + jsr SE731 ; set up color byte + jsr LB156 ; evaluate command string +SF3B8 jsr LB654 ; fetch command string details + bra SF3C5 ; interpret command string +SF3BD jsr SF591 ; fetch command character + jmp SF5A7 ; evaluate number +SF3C3 puls b,x ; get "caller" command string details +SF3C5 stb VD8 ; save string pointer + beq SF3C3 ; brif end of string - try another + stx VD9 ; set string data pointer + lbeq SF4D0 ; brif we hit the top of the stack +SF3CF tst VD8 ; is there anything left? + beq SF3C3 ; brif not + jsr SF591 ; get command character + cmpa #'; ; separator? + beq SF3CF ; brif so - ignore it + cmpa #'' ; '? + beq SF3CF ; brif so - ignore that too + cmpa #'N ; update toggle? + bne SF3E6 ; brif not + com VD5 ; toggle the "update" flag (if set, return to original position after) + bra SF3CF ; process more +SF3E6 cmpa #'B ; blank modifier? + bne SF3EE ; brif not + com VD6 ; toggle "draw" flag - 0 = draw, nonzero = don't draw + bra SF3CF ; process more +SF3EE cmpa #'X ; substring call? + lbeq SF4A1 ; brif so - process it + cmpa #'M ; M (move)? + lbeq SF54C ; brif so - process "move" + pshs a ; save command character + ldb #1 ; default count if no number follows + clr VD3 ; clear MS byte of count + stb VD4 ; save LS byte of count + tst VD8 ; is there anything left? + beq SF417 ; brif not + jsr SF591 ; get command character + jsr LB3A2 ; set C if not alpha + pshs cc ; save alpha flag + jsr SF5F2 ; back up command pointer + puls cc ; get back alpha flag + bcc SF417 ; brif command is alpha + bsr SF3BD ; evaluate decimal string +SF417 puls a ; get command back + cmpa #'C ; C (colour)? + beq SF445 ; brif so + cmpa #'A ; A (angle)? + beq SF451 ; brif so + cmpa #'S ; S (scale)? + beq SF45C ; brif so + cmpa #'U ; U (up)? + beq SF496 ; brif so + cmpa #'D ; D (down)? + beq SF492 ; brif so + cmpa #'L ; L (left)? + beq SF48C ; brif so + cmpa #'R ; R (right)? + beq SF485 ; brif so + suba #'E ; shift E,F,G,H to be 0-3 + beq SF473 ; brif E (UR) + deca ; F (DR) + beq SF46D ; brif so + deca ; G (DL) + beq SF47D ; brif so + deca ; H (UL) + beq SF467 ; brif so + jmp LB44A ; raise error if unrecognized command +SF445 jsr SE711 ; adjust colour code for graphics mode + stb H.FCOLOR ; set new foreground + jsr SE731 ; set up colour byte + lbra SF3CF ; handle another command +SF451 cmpb #4 ; only 4 angles valid + lbhs LB44A ; brif invalid angle + stb ANGLE ; save draw angle + lbra SF3CF ; go handle another command +SF45C cmpb #63 ; only 0-62 are valid scale factors + lbhs LB44A ; brif invalid scale + stb SCALE ; set scale factor + lbra SF3CF ; process another command +SF467 lda VD3 ; get count MSB + bsr NEGACCD ; negate horizontal difference (go left) + bra SF46F ; go the same distance up +SF46D lda VD3 ; get count MSB +SF46F tfr d,x ; go same distance right as down + bra SF4D4 ; go handle movement/drawing +SF473 lda VD3 ; get MSB of count + tfr d,x ; going same distance on both axes + bsr NEGACCD ; negate the vertical distance + exg d,x ; put vertical in X, horizontal in D + bra SF4D4 ; go handle drawing and moving +SF47D lda VD3 ; get MSB of count + tfr d,x ; go same distance on both axes + bsr NEGACCD ; go left horizontally (and down vertically) + bra SF4D4 ; go handle drawing and moving +SF485 lda VD3 ; get MSB of difference (going right) +SF487 ldx #0 ; no vertical movement + bra SF4D4 ; handle drawing/moving +SF48C lda VD3 ; get MSB of count + bsr NEGACCD ; negate because going left + bra SF487 ; set no vertical difference, handle drawing/moving +SF492 lda VD3 ; get MSB of count + bra SF49A ; go make horizontal difference 0, use positive distance for down +SF496 lda VD3 ; get MSB of count + bsr NEGACCD ; use negative distance for up +SF49A ldx #0 ; use 0 horizontal distance + exg x,d ; put horizontal and vertical in the right places + bra SF4D4 ; go move/draw +SF4A1 jsr SF611 ; interpret command as a variable + ldb #2 ; see if we're about to run out of memory + jsr LAC33 + ldb VD8 ; get remaining characters in current command string + ldx VD9 ; get current command string pointer + pshs x,b ; save the stack frame + jmp SF3B8 ; go evaluate the string +SF4B2 ldb SCALE ; get scaling factor + beq SF4D1 ; brif none - use full scale + clra ; zero extend scale + exg d,x ; put distance in D, save scale factor + sta ,-s ; save MSB of distance and set flags on sign + bpl SF4BF ; brif positive distance + bsr NEGACCD ; make it positive if negative +SF4BF jsr SEBCB ; multiply D and X + tfr U,D ; save LSW in D + lsra ; divide by 4 + rorb + lsra + rorb + tst ,s+ ; was original positive? + bpl SF4D0 ; brif so +NEGACCD nega ; negate D + negb + sbca #0 +SF4D0 rts +SF4D1 tfr x,d ; keep unmodified distance + rts +SF4D4 pshs d ; save horizontal distance + bsr SF4B2 ; apply scale factor to vertical distance + puls x ; get back horizontal distance + pshs d ; save scaled vertical distance + bsr SF4B2 ; apply scale to horizontal distance + puls x ; get back the vertical distance + ldy ANGLE ; get draw angle (using Y to avoid clobbering D) + pshs y ; save it +SF4E5 tst ,s ; check angle + beq SF4F1 ; brif no angle + exg x,d ;* swap horizontal and vertical distances then negate new horizontal + bsr NEGACCD ;* distance, which rotates 90° counterclockwise + dec ,s ; count down the angle + bra SF4E5 ; see if we have rotated enough times +SF4F1 puls y ; clean up stack + ldu #0 ; default end position to 0 + addd HORDEF ; add distance to current draw position + bmi SF4FC ; brif we went negative - use minimal 0 + tfr d,u ; use calculated draw coordinate +SF4FC tfr x,d ; fetch vertical distance for calculation + ldx #0 ; default end position to 0 + addd VERDEF ; add distance to draw position + bmi SF507 ; brif we went negative - use minimal 0 + tfr d,x ; use calculated coordinate +SF507 cmpu #640 ; is it out of range completely? + blo SF510 ; brif not + ldu #639 ; maximize to right edge of screen +SF510 lda HRMODE ; get graphics mode + cmpa #2 ; is it a 320 mode? + bgt SF51F ; brif not + cmpu #320 ; out of range for 320 mode? + blo SF51F ; brif not + ldu #319 ; maximize to right edge of screen +SF51F cmpx #192 ; out of range vertically? + blo SF527 ; brif not + ldx #191 ; maximize to bottom of screen +SF527 ldd HORDEF ; set start position to current draw position + std HORBEG + ldd VERDEF + std VERBEG + stx VEREND ; set calculated position as end position + stu HOREND + tst VD5 ; are we going to update draw position? + bne SF53B ; brif not + stx VERDEF ; set new draw position + stu HORDEF +SF53B jsr SEA0D ; "normalize" coordinates + tst VD6 ; are we doing to draw a line? + bne SF545 ; brif not + jsr SE94E ; draw a line +SF545 clr VD5 ; reset the "update" flag + clr VD6 ; reset the "draw" flag + jmp SF3CF ; go handle another command +SF54C jsr SF591 ; get input character + pshs a ; save it + jsr SF578 ; evaluate horizontal distance + pshs d ; save it + jsr SF591 ; get a character + cmpa #', ; is it a comma separator? + lbne LB44A ; brif not - raise error + jsr SF575 ; evaluate the vertical distance + tfr d,x ; save vertical distance + puls u ; get horizontal distance + puls a ; get first command character + cmpa #'+ ; +? + beq SF570 ; treat coordinates as relative displacements + cmpa #'- ; -? + bne SF507 ; brif neither + or -; treat as absolute coordinates +SF570 tfr u,d ; put horizontal distance in D + jmp SF4D4 ; treat distances as offsets +SF575 jsr SF591 ; get character +SF578 cmpa #'+ ; +? + beq SF583 ; brif so - do positive + cmpa #'- ; -? + beq SF584 ; brif so - do negative + jsr SF5F2 ; back up input pointer +SF583 clra ; flag positive +SF584 pshs a ; save sign flag + jsr SF3BD ; evaluate decimal number + tst ,s+ ; is it positive? + beq SF590 ; brif so + negb ; negate the value - BUG: should be JSR NEGACCD; this code sequence doesn't work + sbca #0 +SF590 rts +SF591 pshs x ; save register +SF593 tst VD8 ; is there anything to fetch? + lbeq LB44A ; brif not - raise error + ldx VD9 ; get command pointer + lda ,x+ ; get command character + stx VD9 ; save updated pointer + dec VD8 ; account for character consumed + cmpa #0x20 ; space? + beq SF593 ; brif so - skip it + puls x,pc ; restore register and return +SF5A7 cmpa #'= ; is it variable equate? + bne SF5B6 ; brif not + pshs u,y ; save registers + bsr SF611 ; interpret variable in command string + jsr LB3E9 ; convert to integer in D + std VD3 ; save as count + puls y,u,pc ; restore registers and return +SF5B6 jsr SF608 ; clear carry if numeric + lbcs LB44A ; bail if not numeric + clr VD3 ; initialize count to 0 + clr VD4 +SF5C1 suba #'0 ; remove ASCII bias + sta VD7 ; save digit value + ldd VD3 ; get accumulated value + bsr SF5FD ; multiply by 10 + addb VD7 ; add digit value + adca #0 ; propagate carry + std VD3 ; save accumulated count value + lda HRMODE ; get graphics mode + cmpa #2 ; is it a 640 mode? + bgt SF5DA ; brif so + ldd #319 ; get max for 320 mode + bra SF5DD +SF5DA ldd #639 ; get max for 640 mode +SF5DD cmpd VD3 ; is the value in range for a horizontal coordinate? + lblt LB44A ; brif not + ldd VD3 ; get accumulated value + tst VD8 ; is there anything more to parse? + beq SF5FA ; brif not + jsr SF591 ; get a character + jsr SF608 ; set C if not digit + bcc SF5C1 ; brif digit - add to accumulated value +SF5F2 inc VD8 ; account for character being unfetched + ldx VD9 ; move command pointer back + leax -1,x + stx VD9 +SF5FA ldd VD3 ; get accumulated value + rts +SF5FD aslb ; times 2 + rola + pshs d ; save 2D + aslb ; times 4 + rola + aslb ; times 8 + rola + addd ,s++ ; 8D+2D=10D + rts +SF608 cmpa #'0 ; is it less than ASCII 0? + blo SF610 ; brif so - sets C + suba #'9+1 ; set C if > ASCII 9 + suba #-('9+1) +SF610 rts +SF611 ldx VD9 ; get command pointer + pshs x ; save it + jsr SF591 ; get command character + jsr LB3A2 ; set C if not alpha + lbcs LB44A ; brif not variable name +SF61F jsr SF591 ; get command character + cmpa #'; ; is it end of variable string? + bne SF61F ; brif not + puls x ; get back start of variable + ldu CHARAD ; save interpreter input pointer + pshs u + stx CHARAD ; save command string pointer as interpeter input + jsr LB284 ; evaluate variable + puls x ; restore interpreter input pointer + stx CHARAD + rts +; WIDTH command +WIDTH clr HRMODE ; turn off graphics + lbrn 0 + cmpa #0 ; end of line? (BUG: should do a BEQ before the CLR above) + beq SF64F ; brif so - raise error if no argument (won't trigger on :) + jsr EVALEXPB ; evaluate width argument + cmpb #32 ; 32 columns? + beq COL32 ; brif so + cmpb #40 ; 40 columns? + beq COL40 ; brif so + cmpb #80 ; 80 columns? + beq COL80 ; brif so +SF64F jmp LB44A ; raise FC error +COL32 clra ; set text mode to 32 columns + sta HRWIDTH + jsr LA928 ; clear screen + lbsr SETTEXT ; set up display for 32 column screen + rts +COL40 lda #1 ; mode number for 40 columns + sta HRWIDTH ; set text screen mode + lbsr SF772 ; map text screen + lda #40 ; set up scren size in character cells + ldb #ROWMAX + std H.COLUMN + ldd #HRESSCRN+40*ROWMAX*2 ; set end address of screen +SF66D std H.DISPEN ; save end address + bsr SF68C ; clear the screen + lbsr SF778 ; unmap text screen + lbsr SETTEXT ; set up display for the text screen + rts +COL80 lda #2 ; mode number for 80 columns + sta HRWIDTH ; set text screen mode + lbsr SF772 ; map the screen + lda #80 ; set up screen size in character cells + ldb #ROWMAX + std H.COLUMN + ldd #HRESSCRN+80*ROWMAX*2 ; set end address of screen + bra SF66D ; set up rest of parameters +SF68C ldx #HRESSCRN ; set cursor address to top left corner + lbrn 0 + stx H.CRSLOC + lda #0x20 ; use space to clear screen + ldb H.CRSATT ; get current attributes +SF69B std ,x++ ; blank a character cell + cmpx H.DISPEN ; end of screen? + blo SF69B ; brif not + ldx #HRESSCRN ; reset to top of screen + clra ; reset cursor coordinates to 0,0 + sta H.CURSX + sta H.CURSY + rts +; CLS patch entered from the other patch in the ECB area +ALINK23 puls cc ; restore zero flag + lbrn 0 + beq SF6E0 ; brif no arguments + jsr EVALEXPB ; get colour number + tstb ; 0? + beq SF6E0 ; brif so - treat as no arguments + cmpb #8 ; valid colour? + bhi SF6E7 ; brif not - do the easter egg or the other easter egg + decb ; zero-base the colour + leay IM.PALET,pcr ; point to current palette settings + lda b,y ; get the real colour + sta V.BORDER ; set border colour + lbsr SF766 ; set border colour in GIME initializers + stb H.CRSATT ; set attributes to foreground 0, background as selected, no blink or underline + lda #0x20 ; get space character + lbsr SF772 ; map screen + ldx #HRESSCRN ; get address of start of screen + stx H.CRSLOC ; put cursor there + bsr SF69B ; clear screen +SF6DC lbsr SF778 ; unmap screen + rts +SF6E0 lbsr SF772 ; map screen + bsr SF68C ; clear screen + bra SF6DC ; ummap screen and return +SF6E7 clr H.CRSATT ; reset attributes to colours 0,0, no blink or underline + lda IM.PALET ; get colour in register 0 + sta V.BORDER ; set border colour + bsr SF766 ; reset border colour in GIME initializers + cmpb #100 ; is it CLS 100? +SF6F4 beq SF730 ; brif so - do the easter egg + bsr SF772 ; map the screen + bsr SF68C ; clear screen + bsr SF778 ; unmap screen + ldx #MICROMS-1 ; point to Microware commercial + jmp STRINOUT ; display it +MICROMS fcc 'Microware Systems Corp.' + fcb 0x0d,0x00 +AUTHORMS fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 ; the ROM/RAM copy sets this to the actual easter egg text + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 + fcb 0x00,0x00,0x00,0x00,0x00 +SF730 bsr SF772 ; map the screen + lbsr SF68C ; clear it + bsr SF778 ; unmap the screen + ldx #AUTHORMS-1 ; point to the easter egg + jsr STRINOUT ; display it + pshs x ; save X for some reason + leax >SF6F4,pcr ; point to start of easter egg code + lda #0x12 ; NOP opcode + sta ,x+ ; blank out the branch that brings us here + sta ,x + leax >AUTHORMS,pcr ; point to author message +SF74D sta ,x+ ; blank out character in string or this code + cmpx #SF74D ; end of string or display code? + blo SF74D ; brif not + puls x ; restore X + rts +; Line input routine patch for handling CLEAR +ALINK27 tst HRWIDTH ; is it 40/80 column screen? + bne SF761 ; brif so + jsr LA928 ; clear 32 column screen +SF75E jmp LA390 ; go make to mainline +SF761 lbsr SF6E0 ; clear the screen + bra SF75E ; return to mainline +SF766 pshs y ; save register + leay SE03B,pcr ; point to text initializers + sta 3,y ; set border in 40 column initializer + sta 12,y ; set border in 80 column initializer + puls y,pc ; restore registers and return +SF772 orcc #0x50 ; clobber interrupts + lbsr SELTEXT ; map the text screen (by setting *all 16* MMU registers) + rts +SF778 lbsr SETMMU ; unmap text screen (by setting *all 16* MMU registers) + andcc #0xaf ; restart interrupts + rts +; The driver for putting characters on the 40 and 80 column screen is here, modulo the WIDTH command and clear +; screen routines above. +; +; There are several major problems with this driver: +; +; * Cursor handling is overly complicated. Instead of doing what Color Basic does and only show the cursor +; when waiting for input in the generic input routine, this driver displays it almost all of the time and, thus, +; has all manner of code for managing the cursor that would not be needed otherwise. +; * The system goes out of its way to set up the screen height and width values. Then, it doesn't bother using +; them consistently, especially during the screen scrolling routine. Indeed, the screen scrolling routine could +; be made completely general purpose by using two pointers, say U for the destination and X for the source. Then +; the column count could be used to decide the line width (to calculate the offset betwen U and X) and then the +; row count could be used to set the row number after the scrolling is done. This would remove any hard coded +; offsets or screen size assumptions. +; * The routines for mapping and unmapping the text screen are inexcusably slow. Only one MMU register needs to +; be changed in either routine. However, instead of doing that, the routines use an inefficient routine that +; sets *all 16* MMU registers (both tasks!). This reduces screen output speed so much that a fast reader can +; actually keep up with the output going full speed. Simply replacing these two routines with simpler ones that +; do not do that dumbassery gets performance on par with the 32 column VDG screen. +; +; Along with the above, some of the code is far more convoluted than it needs to be, but that is relatively +; benign compared to everything else. +; +; Blink cursor patch +ALINK24 bsr SF787 ; blink the cursor + jsr KEYIN ; get keypress + beq ALINK24 ; brif no key pressed + puls b,x,pc ; return to caller +SF787 dec BLKCNT ; time to blink cursor? + bne SF7A8 ; brif not + ldb #11 ; reset blink counter + stb BLKCNT + bsr SF772 ; map screen + ldx H.CRSLOC ; get cursor pointer + lda 1,x ; get current attributes + bita #0x40 ; is underline on? + beq SF79F ; brif not - enable it + lda H.CRSATT ; use current attributes if it is + bra SF7A4 +SF79F lda H.CRSATT ; get current attributes + ora #0x40 ; turn on underline +SF7A4 sta 1,x ; save new attributes + bsr SF778 ; unmap screen +SF7A8 ldx #DEBDEL ; do a delay + jmp LA7D3 +; Put character on screen patch +ALINK22 bsr SF772 ; map the screen + lbrn 0 + ldx H.CRSLOC ; get cursor location + cmpa #0x08 ; backspace? + bne SF7C4 ; brif not + cmpx #HRESSCRN ; at start of screen? + beq SF7DE ; brif so - do nothing + bsr SF7E2 ; do a backspace + bra SF7DE ; finish up +SF7C4 cmpa #0x0d ; carriage return? + bne SF7CC ; brif not + bsr SF827 ; do a carriage return + bra SF7D7 ; finish up with scroll check +SF7CC cmpa #0x20 ; is it a control code? + blo SF7DE ; brif so - do nothing + ldb H.CRSATT ; get current attributes + std ,x ; put character on screen + bsr SF807 ; move cursor forward +SF7D7 cmpx H.DISPEN ; end of screen? + blo SF7DE ; brif not + bsr SF854 ; scroll screen +SF7DE bsr SF778 ; unmap the screen + puls a,b,x,pc ; restore registers and return +SF7E2 pshs b,a ; save registers + lda #0x20 ; space character + ldb H.CRSATT ; get attributes + std ,x ; turns off cursor at this position and blanks it + orb #0x40 ; turn on underline (we'll put a cursor in the previous position) + std -2,x ; put blank and cursor back one + leax -2,x ; move pointer back + stx H.CRSLOC ; save new cursor pointer + ldd H.CURSX ; get coordinates + deca ; move horizontal back + bpl SF802 ; brif we didn't wrap + decb ; move vertical back + stb H.CURSY ; save it + lda H.COLUMN ; get screen width + deca ; coordinates are zero-based so now we have the max horizontal coord +SF802 sta H.CURSX ; save new horizontal position + puls a,b,pc ; restore registers and return +SF807 pshs a,b ; save registers + lda #0x20 ; we'll blank a character for the cursor + ldb H.CRSATT ; get attributes + orb #0x40 ; force underline for cursor + leax 2,x ; move pointer forward + std ,x ; put blank and cursor on screen + stx H.CRSLOC ; save new cursor position + ldd H.CURSX ; get coordinates + inca ; move right + cmpa H.COLUMN ; did we hit the edge? + blo SF802 ; brif not - save new horizontal coordinate and return + incb ; bump line + stb H.CURSY ; save new line + clra ; reset to left side of screen + bra SF802 ; save new horizontal coordinate and return +SF827 pshs a,b ; save registers + lda #0x20 ; get space character + ldb H.CRSATT ; get attributes +SF82E std ,x++ ; blank a character + pshs a ; save character + lda H.CURSX ; get horizontal position + inca ; bump it + sta H.CURSX ; save new position + cmpa H.COLUMN ; edge of screen? + puls a ; restore character + blo SF82E ; brif not end of line yet + stx H.CRSLOC ; save cursor location + clr H.CURSX ; reset to left edge + inc H.CURSY ; bump row + lda #0x20 ; space character + ldb H.CRSATT ; get attributes + orb #0x40 ; turn on underline + std ,x ; put a cursor on screen + puls a,b,pc ; restore registers and return +SF854 pshs a,b ; save registers + ldx #HRESSCRN ; point to start of screen + lda H.COLUMN ; get screen width + cmpa #40 ; is it 40 columns? + bne SF86E ; brif not - do 80 column scroll +SF860 ldd 2*40,x ; get character cell from one line down + std ,x++ ; move it here + cmpx #HRESSCRN+(ROWMAX-1)*40*2 ; at start of last row? + blo SF860 ; brif not +SF86A bsr SF87B ; fill last row with spaces + puls a,b,pc ; restore registers and return +SF86E ldd 80*2,x ; get a character cell from next row + std ,x++ ; put it here + cmpx #HRESSCRN+(ROWMAX-1)*80*2 ; at start of last row? + blo SF86E ; brif not + bra SF86A ; blank out last row and finish up +SF87B clr H.CURSX ; reset column to 0 + lda #ROWMAX-1 ; reset row number to bottom of screen + sta H.CURSY + lda #0x20 ; get space character + ldb H.CRSATT ; get attributes + pshs x ; save pointer to start of row +SF88A std ,x++ ; blank a character + cmpx H.DISPEN ; at end of screen? + bne SF88A ; brif not + clr H.CURSX ; reset horizontal position to margin + puls x ; get start of line pointer + lda #0x20 ; space haracter + ldb H.CRSATT ; get attributes + orb #0x40 ; turn on underline + std ,x ; put a bleeping cursor at start of line + stx H.CRSLOC ; set cursor position + rts +; Conditional newline patch. Note that this maps and unmaps the text screen in 40/80 column mode +; but that is completely unneeded to just test the X coordinate. +ALINK26 tst DEVNUM ; is it screen? + bne SF8AB ; brif not + tst HRWIDTH ; VDG screen? + bne SF8B1 ; brif not +SF8AB jsr LA35F ; set up print parameters + jmp LB95F ; re-enter mainline code +SF8B1 lbsr SF772 ; map screen + tst H.CURSX ; at left margin? + pshs cc ; save Z flag + lbsr SF778 ; unmap screen + puls cc ; get back Z flag + lbne LB958 ; brif not at left margine - do CR + rts +; PRINT @ patch +ALINK25 tst HRWIDTH ; VDG screen? + bne SF8CD ; brif not - raise error + jsr LA554 ; move cursor to specified position + jmp LB905 ; return to mainline code +SF8CD ldb #39*2 ; code for HP error + jmp LAC46 ; raise error +; LOCATE command +; The parameter checking here could simply use the H.COLUMN and H.ROW variables and it would +; be loads simpler. Also, if the dumbassery with the cursor wasn't a thing, this routine wouldn't +; need to mess with mapping the screen or screwing around with the cursor. +LOCATE ldb HRWIDTH ; is it 40/80 column screen? + lbrn 0 + beq SF8CD ; brif not - raise error + pshs b ; save screen mode + jsr SE7B2 ; evaluate coordinates + lda BINVAL+1 ; get X coordinate + puls b ; get back screen mode + cmpb #1 ; is it 40 column screen? + bne SF8EB ; brif not + cmpa #40 ; in range for 40 columns? + bra SF8ED +SF8EB cmpa #80 ; in range for 80 columns? +SF8ED lbhs LB44A ; brif not - raise error + ldb VERBEG+1 ; get Y coordinate + cmpb #ROWMAX ; is it in range? + bhs SF8ED ; brif not - raise error + pshs d ; save new coordinates + lbsr SF772 ; map screen + std H.CURSX ; set screen coordinates + ldx H.CRSLOC ; get pointer to old position + lda H.CRSATT ; replace attributes with current ones + sta 1,x + lda H.COLUMN ; get number of columns (why not use this above?) + asla ; two bytes per character cell + mul ; now D is offset to start of row + ldx #HRESSCRN ; get start of screen + leax d,x ; now X points to the start of the line + puls a,b ; get back column and row numbers + asla ; two bytes per character cell + tfr a,b ; need this in B since we'll overflow singed 8 bits + abx ; offset to correct cursor position + lda H.CRSATT ; get attributes + ora #0x40 ; enable underline + sta 1,x ; enable cursor + stx H.CRSLOC ; save new cursor pointer + lbsr SF778 ; unmap screen + rts +; HSTAT command +HSTAT tst HRWIDTH ; is it 40/80 column screen? + lbrn 0 + beq SF8CD ; brif not - raise error + lbsr SF772 ; map the screen + ldx H.CRSLOC ; get cursor pointer + ldd ,x ; get character and attributes + std VCB ; save them + ldd H.CURSX ; get screen coordinates + std VCD ; save them + lbsr SF778 ; unmap screen + jsr LB357 ; evaluate variable for character + stx VARDES ; saveit + jsr SYNCOMMA ; insist on a comma + ldb #1 ; make a single character string + jsr LB56D + lda VCB ; get character on screen + jsr LB511 ; get string details + sta ,x ; save character in string + jsr LB54C ; put string on string stack + ldx VARDES ; point to variable descriptor + tst -1,x ; is it a string? (should have checked after evaluating instead) + lbpl LB151 ; do type mismatch if number + ldy FPA0+2 ; point to destination string descriptor + ldb #5 ; copy 5 bytes from newly created string into variable +SF963 lda ,y+ ; copy byte + sta ,x+ + decb ; done all? + bne SF963 ; brif not + LDX TEMPPT ; point to new string descriptor + leax -5,x ; BUG: should just call LB675 to remove string from string stack + stx TEMPPT + jsr LB357 ; evaluate a variable (for X coord) + stx VARDES ; save pointer to it + jsr SYNCOMMA ; insist on a comma after it + clra ; zero extend attributes + ldb VCB+1 ; get attribute byte + jsr GIVABF ; convert to float + ldx VARDES ; point to variable + tst -1,x ; test if numeric (should have tested VALTYP above) + lbmi LB151 ; TM error if not number + jsr LBC35 ; pack FPA0 to variable + jsr LB357 ; evaluate another variable + stx VARDES ; save it + jsr SYNCOMMA ; insist on a comma + clra ; zero extend the X coordinate + ldb VCD ; get X coordinate + jsr GIVABF ; turn into a FP number + ldx VARDES ; get variable + tst -1,x ; is it a number (should have tested VALTYP above) + LBMI LB151 ; brif not - TM error + jsr LBC35 ; pack FPA0 to variable + jsr LB357 ; evaluate another variable + stx VARDES ; save it + clra ; zero extend Y coordinate + ldb VCD+1 ; get Y coordinate + jsr GIVABF ; turn into a FP number + ldx VARDES ; get variable descriptor back + tst -1,x ; is it a number (should have tested VALTYP above) + lbmi LB151 ; brif not - TM error + jsr LBC35 ; pack FPA0 to variable + rts +; ATTR command +ATTR jsr EVALEXPB ; evaluate foreground colour + lbrn 0 + cmpb #8 ; there are 8 valid colours (0-7) + lbhs LB44A ; brif out of range - raise error + aslb ; shift over to bits 5,4,3 + aslb + aslb + pshs b ; save partial attribute byte + jsr GETCCH ; fetch current character (useless call) + jsr SYNCOMMA ; insist on comma + jsr EVALEXPB ; evaluate background colour + cmpb #8 ; is it valid (0-7)? + lbhs LB44A ; brif not - raise error + orb ,s ; merge with partial attribute byte + leas 1,s ; clean up stack (could use ,s+ above) + andb #0x3f ; make sure we have zeros in bit 7,6 - unneeded + pshs b ; save colour attributes + jsr GETCCH ; is there mode? +SF9E3 beq SFA06 ; brif no more flags + jsr SYNCOMMA ; insist on a comma + cmpa #'B ; B (blink)? + bne SF9F6 ; brif not + puls b ; set blink bit in accumulated attributes + orb #0x80 + pshs b + jsr GETNCH ; eat the flag + bra SF9E3 ; look for another flag +SF9F6 cmpa #'U ; U (underline)? + lbne LB44A ; invalid flag - raise error + puls b ; get accumulated attributes and set underline bit + orb #0x40 + pshs b + jsr GETNCH ; eat the flag + bra SF9E3 ; look for another flag +SFA06 puls b ; get new attributes + stb H.CRSATT ; set them as default + rts + fcb 0x00,0x00,0x00,0x00 ; unused bytes +; These are extra glyphs that should be part of the HPRINT font but aren't. + fcb 0x38,0x44,0x40,0x40,0x40,0x44,0x38,0x10 ; Ç + fcb 0x44,0x00,0x44,0x44,0x44,0x4C,0x34,0x00 ; ü + fcb 0x08,0x10,0x38,0x44,0x7C,0x40,0x38,0x00 ; é + fcb 0x10,0x28,0x38,0x04,0x3C,0x44,0x3C,0x00 ; â + fcb 0x28,0x00,0x38,0x04,0x3C,0x44,0x3C,0x00 ; ä + fcb 0x20,0x10,0x38,0x04,0x3C,0x44,0x3C,0x00 ; à + fcb 0x10,0x00,0x38,0x04,0x3C,0x44,0x3C,0x00 ; ȧ (or å maybe?) + fcb 0x00,0x00,0x38,0x44,0x40,0x44,0x38,0x10 ; ç + fcb 0x10,0x28,0x38,0x44,0x7C,0x40,0x38,0x00 ; ê + fcb 0x28,0x00,0x38,0x44,0x7C,0x40,0x38,0x00 ; ë + fcb 0x20,0x10,0x38,0x44,0x7C,0x40,0x38,0x00 ; è + fcb 0x28,0x00,0x30,0x10,0x10,0x10,0x38,0x00 ; ï + fcb 0x10,0x28,0x00,0x30,0x10,0x10,0x38,0x00 ; î + fcb 0x00,0x18,0x24,0x38,0x24,0x24,0x38,0x40 ; ẞ + fcb 0x44,0x10,0x28,0x44,0x7C,0x44,0x44,0x00 ; Ä + fcb 0x10,0x10,0x28,0x44,0x7C,0x44,0x44,0x00 ; Ȧ (or Å maybe?) + fcb 0x08,0x10,0x38,0x44,0x44,0x44,0x38,0x00 ; ó + fcb 0x00,0x00,0x68,0x14,0x3C,0x50,0x3C,0x00 ; æ + fcb 0x3C,0x50,0x50,0x78,0x50,0x50,0x5C,0x00 ; Æ + fcb 0x10,0x28,0x38,0x44,0x44,0x44,0x38,0x00 ; ô + fcb 0x28,0x00,0x38,0x44,0x44,0x44,0x38,0x00 ; ö + fcb 0x00,0x00,0x38,0x4C,0x54,0x64,0x38,0x00 ; ø + fcb 0x10,0x28,0x00,0x44,0x44,0x4C,0x34,0x00 ; û + fcb 0x20,0x10,0x44,0x44,0x44,0x4C,0x34,0x00 ; ù + fcb 0x38,0x4C,0x54,0x54,0x54,0x64,0x38,0x00 ; Ø + fcb 0x44,0x38,0x44,0x44,0x44,0x44,0x38,0x00 ; Ö + fcb 0x28,0x44,0x44,0x44,0x44,0x44,0x38,0x00 ; Ü + fcb 0x38,0x40,0x38,0x44,0x38,0x04,0x38,0x00 ; § + fcb 0x08,0x14,0x10,0x38,0x10,0x50,0x3C,0x00 ; £ + fcb 0x10,0x10,0x7C,0x10,0x10,0x00,0x7C,0x00 ; ± + fcb 0x10,0x28,0x10,0x00,0x00,0x00,0x00,0x00 ; ° + fcb 0x08,0x14,0x10,0x38,0x10,0x10,0x20,0x40 ; ſ (long s) +; These are some extra symbol glyphs + fcb 0x00,0x10,0x18,0x1C,0x1C,0x18,0x10,0x00 ; solid right pointing triangle + fcb 0x00,0x08,0x18,0x38,0x38,0x18,0x08,0x00 ; solid left pointing triangle + fcb 0x00,0x00,0x00,0x7E,0x3C,0x18,0x00,0x00 ; solid down pointing triangle + fcb 0x00,0x00,0x18,0x3C,0x7E,0x00,0x00,0x00 ; solid up pointing triangle + fcb 0x00,0xFF,0x00,0xFF,0xFF,0x00,0xFF,0x00 ; three horizontal lines with middle one double thick + fcb 0x00,0x00,0x30,0x3C,0x14,0x1C,0x00,0x00 ; solid square on top left of open square + fcb 0x00,0x7E,0x42,0x5A,0x5A,0x42,0x7E,0x00 ; solid box inside larger box + fcb 0x00,0x7E,0x7E,0x00,0x00,0x7E,0x7E,0x00 ; thick equals sign + fcb 0x00,0x3C,0x3C,0x3C,0x3C,0x3C,0x3C,0x00 ; solid vertical rectangle + fcb 0x00,0x00,0x7E,0x7E,0x7E,0x7E,0x00,0x00 ; solid horizontal rectangle + fcb 0x00,0x7E,0x24,0x18,0x18,0x24,0x7E,0x00 ; hour glass + fcb 0x00,0x7F,0x00,0x7F,0x7F,0x00,0x7F,0x00 ; left end three horizontal lines with middle one double thick + fcb 0x00,0xFE,0x00,0xFE,0xFE,0x00,0xFE,0x00 ; right end three horizontal lines with middle one double thick +; The above 45 glyphs are duplicated below + fcb 0x38,0x44,0x40,0x40,0x40,0x44,0x38,0x10 + fcb 0x44,0x00,0x44,0x44,0x44,0x4C,0x34,0x00 + fcb 0x08,0x10,0x38,0x44,0x7C,0x40,0x38,0x00 + fcb 0x10,0x28,0x38,0x04,0x3C,0x44,0x3C,0x00 + fcb 0x28,0x00,0x38,0x04,0x3C,0x44,0x3C,0x00 + fcb 0x20,0x10,0x38,0x04,0x3C,0x44,0x3C,0x00 + fcb 0x10,0x00,0x38,0x04,0x3C,0x44,0x3C,0x00 + fcb 0x00,0x00,0x38,0x44,0x40,0x44,0x38,0x10 + fcb 0x10,0x28,0x38,0x44,0x7C,0x40,0x38,0x00 + fcb 0x28,0x00,0x38,0x44,0x7C,0x40,0x38,0x00 + fcb 0x20,0x10,0x38,0x44,0x7C,0x40,0x38,0x00 + fcb 0x28,0x00,0x30,0x10,0x10,0x10,0x38,0x00 + fcb 0x10,0x28,0x00,0x30,0x10,0x10,0x38,0x00 + fcb 0x00,0x18,0x24,0x38,0x24,0x24,0x38,0x40 + fcb 0x44,0x10,0x28,0x44,0x7C,0x44,0x44,0x00 + fcb 0x10,0x10,0x28,0x44,0x7C,0x44,0x44,0x00 + fcb 0x08,0x10,0x38,0x44,0x44,0x44,0x38,0x00 + fcb 0x00,0x00,0x68,0x14,0x3C,0x50,0x3C,0x00 + fcb 0x3C,0x50,0x50,0x78,0x50,0x50,0x5C,0x00 + fcb 0x10,0x28,0x38,0x44,0x44,0x44,0x38,0x00 + fcb 0x28,0x00,0x38,0x44,0x44,0x44,0x38,0x00 + fcb 0x00,0x00,0x38,0x4C,0x54,0x64,0x38,0x00 + fcb 0x10,0x28,0x00,0x44,0x44,0x4C,0x34,0x00 + fcb 0x20,0x10,0x44,0x44,0x44,0x4C,0x34,0x00 + fcb 0x38,0x4C,0x54,0x54,0x54,0x64,0x38,0x00 + fcb 0x44,0x38,0x44,0x44,0x44,0x44,0x38,0x00 + fcb 0x28,0x44,0x44,0x44,0x44,0x44,0x38,0x00 + fcb 0x38,0x40,0x38,0x44,0x38,0x04,0x38,0x00 + fcb 0x08,0x14,0x10,0x38,0x10,0x50,0x3C,0x00 + fcb 0x10,0x10,0x7C,0x10,0x10,0x00,0x7C,0x00 + fcb 0x10,0x28,0x10,0x00,0x00,0x00,0x00,0x00 + fcb 0x08,0x14,0x10,0x38,0x10,0x10,0x20,0x40 + fcb 0x00,0x10,0x18,0x1C,0x1C,0x18,0x10,0x00 + fcb 0x00,0x08,0x18,0x38,0x38,0x18,0x08,0x00 + fcb 0x00,0x00,0x00,0x7E,0x3C,0x18,0x00,0x00 + fcb 0x00,0x00,0x18,0x3C,0x7E,0x00,0x00,0x00 + fcb 0x00,0xFF,0x00,0xFF,0xFF,0x00,0xFF,0x00 + fcb 0x00,0x00,0x30,0x3C,0x14,0x1C,0x00,0x00 + fcb 0x00,0x7E,0x42,0x5A,0x5A,0x42,0x7E,0x00 + fcb 0x00,0x7E,0x7E,0x00,0x00,0x7E,0x7E,0x00 + fcb 0x00,0x3C,0x3C,0x3C,0x3C,0x3C,0x3C,0x00 + fcb 0x00,0x00,0x7E,0x7E,0x7E,0x7E,0x00,0x00 + fcb 0x00,0x7E,0x24,0x18,0x18,0x24,0x7E,0x00 + fcb 0x00,0x7F,0x00,0x7F,0x7F,0x00,0x7F,0x00 + fcb 0x00,0xFE,0x00,0xFE,0xFE,0x00,0xFE,0x00 +; The glyphs above repeat one more time here but the set is incomplete + fcb 0x38,0x44,0x40,0x40,0x40,0x44,0x38,0x10 + fcb 0x44,0x00,0x44,0x44,0x44,0x4C,0x34,0x00 + fcb 0x08,0x10,0x38,0x44,0x7C,0x40,0x38,0x00 + fcb 0x10,0x28,0x38,0x04,0x3C,0x44,0x3C,0x00 + fcb 0x28,0x00,0x38,0x04,0x3C,0x44,0x3C,0x00 + fcb 0x20,0x10,0x38,0x04,0x3C,0x44,0x3C,0x00 + fcb 0x10,0x00,0x38,0x04,0x3C,0x44,0x3C,0x00 + fcb 0x00,0x00,0x38,0x44,0x40,0x44,0x38,0x10 + fcb 0x10,0x28,0x38,0x44,0x7C,0x40,0x38,0x00 + fcb 0x28,0x00,0x38,0x44,0x7C,0x40,0x38,0x00 + fcb 0x20,0x10,0x38,0x44,0x7C,0x40,0x38,0x00 + fcb 0x28,0x00,0x30,0x10,0x10,0x10,0x38,0x00 + fcb 0x10,0x28,0x00,0x30,0x10,0x10,0x38,0x00 + fcb 0x00,0x18,0x24,0x38,0x24,0x24,0x38,0x40 + fcb 0x44,0x10,0x28,0x44,0x7C,0x44,0x44,0x00 + fcb 0x10,0x10,0x28,0x44,0x7C,0x44,0x44,0x00 + fcb 0x08,0x10,0x38,0x44,0x44,0x44,0x38,0x00 + fcb 0x00,0x00,0x68,0x14,0x3C,0x50,0x3C,0x00 + fcb 0x3C,0x50,0x50,0x78,0x50,0x50,0x5C,0x00 + fcb 0x10,0x28,0x38,0x44,0x44,0x44,0x38,0x00 + fcb 0x28,0x00,0x38,0x44,0x44,0x44,0x38,0x00 + fcb 0x00,0x00,0x38,0x4C,0x54,0x64,0x38,0x00 + fcb 0x10,0x28,0x00,0x44,0x44,0x4C,0x34,0x00 + fcb 0x20,0x10,0x44,0x44,0x44,0x4C,0x34,0x00 + fcb 0x38,0x4C,0x54,0x54,0x54,0x64,0x38,0x00 + fcb 0x44,0x38,0x44,0x44,0x44,0x44,0x38,0x00 + fcb 0x28,0x44,0x44,0x44,0x44,0x44,0x38,0x00 + fcb 0x38,0x40,0x38,0x44,0x38,0x04,0x38,0x00 + fcb 0x08,0x14,0x10,0x38,0x10,0x50,0x3C,0x00 + fcb 0x10,0x10,0x7C,0x10,0x10,0x00,0x7C,0x00 + fcb 0x10,0x28,0x10,0x00,0x00,0x00,0x00,0x00 + fcb 0x08,0x14,0x10,0x38,0x10,0x10,0x20,0x40 + fcb 0x00,0x10,0x18,0x1C,0x1C,0x18,0x10,0x00 + fcb 0x00,0x08,0x18,0x38,0x38,0x18,0x08,0x00 ; final duplicated glyph: left pointing solid triangle + fcb 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 ; junk unused (or blank space) + fcb 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF ; junk unused (or solid block) +; This is where the constant page (FExx) would start. It's just garbage in the ROM. + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 +; This is where the I/O page would start. It's just garbage in the ROM until the interrupt vectors. + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 + fill 0x00,8 + fill 0xff,8 +; These are the actual CPU interrupt vectors + fdb 0x0000 ; would be the 6309 illegal instruction trap + fdb INT.SWI3 ; SWI3 bounce vector address + fdb INT.SWI2 ; SWI2 bounce vector address + fdb INT.FIRQ ; FIRQ bounce vector address + fdb INT.IRQ ; IRQ bounce vector address + fdb INT.SWI ; SWI bounce vector address + fdb INT.NMI ; NMI bounce vector address + fdb L8C1B ; this is where execution starts on RESET or power on