Mercurial > hg > index.cgi
view bas12.s @ 0:605ff82c4618
Initial check in with cleaned up sources
This is the initial check in the source code in a state where it builds byte
accurate copies of all the various ROM versions included.
| author | William Astle <lost@l-w.ca> |
|---|---|
| date | Sat, 08 Dec 2018 19:57:01 -0700 |
| parents | |
| children |
line wrap: on
line source
*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