Mercurial > hg > index.cgi
view exbas10.s @ 1:704b2c9dc19e default tip
Remove extraneous unused and incorrect definition
| author | William Astle <lost@l-w.ca> |
|---|---|
| date | Wed, 02 Jan 2019 10:11:19 -0700 |
| parents | 605ff82c4618 |
| children |
line wrap: on
line source
*pragma nolist include defs.s ; These are the entry points in the Color Basic ROM which are used the the Extended Basic ROM. ; They are included here in order to keep the Extended Basic ROM separate from the Color Basic ; ROM. BAWMST EQU 0xA0E8 CLOAD EQU 0xA498 CSAVE EQU 0xA44C DATA EQU 0xAEE0 EVALEXPB EQU 0xB70B GIVABF EQU 0xB4F4 INT EQU 0xBCEE LA0E2 EQU 0xA0E2 LA171 EQU 0xA171 LA176 EQU 0xA176 LA35F EQU 0xA35F LA3ED EQU 0xA3ED LA406 EQU 0xA406 LA429 EQU 0xA429 LA42D EQU 0xA42D LA444 EQU 0xA444 LA491 EQU 0xA491 LA505 EQU 0xA505 LA578 EQU 0xA578 LA59A EQU 0xA59A LA5A5 EQU 0xA5A5 LA5AE EQU 0xA5AE LA5C7 EQU 0xA5C7 LA5E4 EQU 0xA5E4 LA616 EQU 0xA616 LA619 EQU 0xA619 LA635 EQU 0xA635 LA644 EQU 0xA644 LA648 EQU 0xA648 LA65F EQU 0xA65F LA7E9 EQU 0xA7E9 LA974 EQU 0xA974 LA976 EQU 0xA976 LA9A2 EQU 0xA9A2 LA9BB EQU 0xA9BB LAC1E EQU 0xAC1E LAC33 EQU 0xAC33 LAC46 EQU 0xAC46 LAC60 EQU 0xAC60 LAC73 EQU 0xAC73 LAC7C EQU 0xAC7C LAC9D EQU 0xAC9D LACA8 EQU 0xACA8 LACEF EQU 0xACEF LACF1 EQU 0xACF1 LAD01 EQU 0xAD01 LAD19 EQU 0xAD19 LAD21 EQU 0xAD21 LAD26 EQU 0xAD26 LAD33 EQU 0xAD33 LAD9E EQU 0xAD9E LADC6 EQU 0xADC6 LADD4 EQU 0xADD4 LADEB EQU 0xADEB LAE15 EQU 0xAE15 LAED2 EQU 0xAED2 LAF67 EQU 0xAF67 LAFA4 EQU 0xAFA4 LB035 EQU 0xB035 LB141 EQU 0xB141 LB143 EQU 0xB143 LB146 EQU 0xB146 LB156 EQU 0xB156 LB158 EQU 0xB158 LB244 EQU 0xB244 LB262 EQU 0xB262 LB267 EQU 0xB267 LB26A EQU 0xB26A LB26F EQU 0xB26F LB277 EQU 0xB277 LB284 EQU 0xB284 LB2CE EQU 0xB2CE LB357 EQU 0xB357 LB35C EQU 0xB35C LB3A2 EQU 0xB3A2 LB44A EQU 0xB44A LB4F3 EQU 0xB4F3 LB50F EQU 0xB50F LB518 EQU 0xB518 LB51A EQU 0xB51A LB56D EQU 0xB56D LB643 EQU 0xB643 LB654 EQU 0xB654 LB657 EQU 0xB657 LB659 EQU 0xB659 LB69B EQU 0xB69B LB6A4 EQU 0xB6A4 LB6AD EQU 0xB6AD LB70E EQU 0xB70E LB734 EQU 0xB734 LB738 EQU 0xB738 LB73D EQU 0xB73D LB740 EQU 0xB740 LB7C2 EQU 0xB7C2 LB958 EQU 0xB958 LB95C EQU 0xB95C LB99F EQU 0xB99F LB9AC EQU 0xB9AC LB9AF EQU 0xB9AF LB9B4 EQU 0xB9B4 LB9B9 EQU 0xB9B9 LB9C2 EQU 0xB9C2 LBA1C EQU 0xBA1C LBA3A EQU 0xBA3A LBA92 EQU 0xBA92 LBAC5 EQU 0xBAC5 LBACA EQU 0xBACA LBB48 EQU 0xBB48 LBB5C EQU 0xBB5C LBB6A EQU 0xBB6A LBB82 EQU 0xBB82 LBB8F EQU 0xBB8F LBC14 EQU 0xBC14 LBC2F EQU 0xBC2F LBC35 EQU 0xBC35 LBC4C EQU 0xBC4C LBC5F EQU 0xBC5F LBC6D EQU 0xBC6D LBCA0 EQU 0xBCA0 LBCC8 EQU 0xBCC8 LBD99 EQU 0xBD99 LBDB6 EQU 0xBDB6 LBDBB EQU 0xBDBB LBDC0 EQU 0xBDC0 LBDC5 EQU 0xBDC5 LBDCC EQU 0xBDCC LBDD9 EQU 0xBDD9 LBEC0 EQU 0xBEC0 LBEC5 EQU 0xBEC5 LBEE9 EQU 0xBEE9 LBEF0 EQU 0xBEF0 LBEFF EQU 0xBEFF LBFA6 EQU 0xBFA6 LET EQU 0xAF89 PUTCHR EQU 0xA282 SIN EQU 0xBF78 SNDBLK EQU 0xA7F4 STRINOUT EQU 0xB99C SYNCOMMA EQU 0xB26D WRLDR EQU 0xA7D8 *pragma list ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; EXTENDED COLOR BASIC ROM ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; org EXBAS fcc 'EX' ; magic number that Color Basic uses to identify the presence of Extended Basic L8002 ldx #L80DE ; point to command interpretation table information ldu #COMVEC+10 ; point to command interpretation table location ldb #10 ; 10 bytes to move jsr LA59A ; copy command interpretation table ldx #LB277 ; initialize Disk Basic's entries to error stx 3,u stx 8,u ldx #XIRQSV ; set up IRQ service routine stx IRQVEC+1 ldx ZERO ; reset the TIMER value stx TIMVAL jsr XVEC18 ; do a bunch of initialization ldd #0x2c05 ; initialize DLOAD baud rate constant and timeout std DLBAUD ldx #USR0 ; set up pointer to USR routine addresses stx USRADR ldu #LB44A ; set up USR routine addresses to "FC error" ldb #10 ; there are 10 routines L8031 stu ,x++ ; set a routine to FC error decb ; done all? bne L8031 ; brif not lda #0x7e ; op code of JMP extended (for RAM hook intialization) sta RVEC20 ; command interpretation loop ldx #XVEC20 stx RVEC20+1 sta RVEC15 ; expression evaluation ldx #XVEC15 stx RVEC15+1 sta RVEC19 ; number parsing ldx #XVEC19 stx RVEC19+1 sta RVEC9 ; PRINT ldx #XVEC9 stx RVEC9+1 sta RVEC17 ; error handler ldx #XVEC17 stx RVEC17+1 sta RVEC4 ; generic input ldx #XVEC4 stx RVEC4+1 sta RVEC3 ; generic output ldx #XVEC3 stx RVEC3+1 sta RVEC8 ; close file ldx #XVEC8 stx RVEC8+1 sta RVEC23 ; tokenize line ldx #XVEC23 stx RVEC23+1 sta RVEC18 ; RUN ldx #XVEC18 stx RVEC18+1 sta EXPJMP ; exponentiation ldx #L8489 stx EXPJMP+1 jsr L96E6 ; initialize graphics stuff lda PIA0+3 ; enable 60Hz interrupt ora #1 sta PIA0+3 ldx #'D*256+'K ; magic number for a Disk Basic ROM cmpx DOSBAS ; do we have a Disk Basic ROM? lbeq DOSBAS+2 ; brif so - launch it andcc #0xaf ; enable interrupts ldx #L80E8-1 ; show sign on message jsr STRINOUT ldx #XBWMST ; install warm start handler stx RSTVEC jmp LA0E2 ; set up warm start flag and launch immediate mode ; Extended Basic warm start code XBWMST nop ; flag to mark routine as valid clr PLYTMR ; cancel any PLAY command in progress clr PLYTMR+1 lda PIA0+3 ; enable 60Hz interrupt ora #1 sta PIA0+3 jmp BAWMST ; let Color Basic's warm start process run ; This routine is dead code that is never used by any Basic ROMs. L80D0 lda PIA1+2 ; check memory size jump bita #2 bne L80DA ; brif high sta SAMREG+29 ; set SAM for 64K memory size L80DA jmp ,x ; jump to address in X fcb 0,0 ; dead space L80DE fcb 25 ; 25 Extended Basic commands fdb L8183 ; reserved word table (commands) fdb L813C ; interpretation handler (commands) fcb 14 ; 14 Extended Basic functions fdb L821E ; reserved word table (functions) fdb L8168 ; function handler L80E8 fcc 'EXTENDED COLOR BASIC 1.0' fcb 0x0d fcc 'COPYRIGHT (C) 1980 BY TANDY' fcb 0x0d fcc 'UNDER LICENSE FROM MICROSOFT' fcb 0x0d,0x0d,0x00 ; Extended Basic command interpretation loop L813C cmpa #0xcb ; is it an Extended Basic command? bhi L8148 ; brif not ldx #L81F0 ; point to dispatch table suba #0xb5 ; normalize the token number so 0 is the first entry jmp LADD4 ; go transfer control to the command L8148 cmpa #0xff ; is it a function token? beq L8154 ; brif so - for MID$()=, TIMER= cmpa #0xcd ; is it a token for a keyword that isn't a command? bls L8165 ; brif so - error for USING and FN jmp [COMVEC+23] ; transfer control to Disk Basic if it is present L8154 jsr GETNCH ; get token after the function flag cmpa #0x90 ; MID$? lbeq L86D6 ; brif so (substring replacement) cmpa #0x9f ; TIMER? lbeq L8960 ; brif so - TIMER setting jsr RVEC22 ; do a RAM hook in case something wants to extend this L8165 jmp LB277 ; we have nothing valid here ; Function handler L8168 cmpb #2*33 ; is it a valid Extended Basic function? bls L8170 ; brif so jmp [COMVEC+28] ; transfer control to Disk Basic if it is present L8170 subb #2*20 ; normalize Extended Basic functions to 0 cmpb #2*8 ; Above HEX$? bhi L817D ; brif so - we don't pre-evaluate an argument pshs b ; save token value jsr LB262 ; evaluate the function parameter puls b ; get back token value L817D ldx #L8257 ; point to dispatch table jmp LB2CE ; go transfer control to the function ; Reserved words (commands) L8183 fcs 'DEL' ; 0xb5 fcs 'EDIT' ; 0xb6 fcs 'TRON' ; 0xb7 fcs 'TROFF' ; 0xb8 fcs 'DEF' ; 0xb9 fcs 'LET' ; 0xba fcs 'LINE' ; 0xbb fcs 'PCLS' ; 0xbc fcs 'PSET' ; 0xbd fcs 'PRESET' ; 0xbe fcs 'SCREEN' ; 0xbf fcs 'PCLEAR' ; 0xc0 fcs 'COLOR' ; 0xc1 fcs 'CIRCLE' ; 0xc2 fcs 'PAINT' ; 0xc3 fcs 'GET' ; 0xc4 fcs 'PUT' ; 0xc5 fcs 'DRAW' ; 0xc6 fcs 'PCOPY' ; 0xc7 fcs 'PMODE' ; 0xc8 fcs 'PLAY' ; 0xc9 fcs 'DLOAD' ; 0xca fcs 'RENUM' ; 0xcb fcs 'FN' ; 0xcc fcs 'USING' ; 0xcd ; Dispatch table (commands) L81F0 fdb DEL ; 0xb5 DEL fdb EDIT ; 0xb6 EDIT fdb TRON ; 0xb7 TRON fdb TROFF ; 0xb8 TROFF fdb DEF ; 0xb9 DEF fdb LET ; 0xba LET (note: implemented by Color Basic!) fdb LINE ; 0xbb LINE fdb PCLS ; 0xbc PCLS fdb PSET ; 0xbd PSET fdb PRESET ; 0xbe PRESET fdb SCREEN ; 0xbf SCREEN fdb PCLEAR ; 0xc0 PCLEAR fdb COLOR ; 0xc1 COLOR fdb CIRCLE ; 0xc2 CIRCLE fdb PAINT ; 0xc3 PAINT fdb GET ; 0xc4 GET fdb PUT ; 0xc5 PUT fdb DRAW ; 0xc6 DRAW fdb PCOPY ; 0xc7 PCOPY fdb PMODETOK ; 0xc8 PMODE fdb PLAY ; 0xc9 PLAY fdb DLOAD ; 0xca DLOAD fdb RENUM ; 0xcb RENUM ; Reserved words (functions) L821E fcs 'ATN' ; 0x94 fcs 'COS' ; 0x95 fcs 'TAN' ; 0x96 fcs 'EXP' ; 0x97 fcs 'FIX' ; 0x98 fcs 'LOG' ; 0x99 fcs 'POS' ; 0x9a fcs 'SQR' ; 0x9b fcs 'HEX$' ; 0x9c fcs 'VARPTR' ; 0x9d fcs 'INSTR' ; 0x9e fcs 'TIMER' ; 0x9f fcs 'PPOINT' ; 0xa0 fcs 'STRING$' ; 0xa1 ; Dispatch table (functions) L8257 fdb ATN ; 0x94 ATN fdb COS ; 0x95 COS fdb TAN ; 0x96 TAN fdb EXP ; 0x97 EXP fdb FIX ; 0x98 FIX fdb LOG ; 0x99 LOG fdb POS ; 0x9a POS fdb SQR ; 0x9b SQR fdb HEXDOL ; 0x9c HEX$ fdb VARPTRTOK ; 0x9d VARPTR fdb INSTR ; 0x9e INSTR fdb TIMER ; 0x9f TIMER fdb PPOINT ; 0xa0 PPOINT fdb STRING ; 0xa1 STRING$ ; Generic output handler XVEC3 tst DEVNUM ; screen? lbeq L95AC ; brif so - force text screen active pshs b ; save register ldb DEVNUM ; get output device cmpb #-3 ; check for DLOAD puls b ; restore register bne L8285 ; brif not DLOAD leas 2,s ; bail out of output handler if DLOAD L8285 rts ; Close file handler. This corrects a bug in Color Basic 1.0 which didn't handle writing the ; end of file block correctly. That bug is fixed in Color Basic 1.1 so this isn't required ; if a recent enough version of Color Basic is installed. XVEC8 lda DEVNUM ; get device number inca ; is it tape? bne L8285 ; brif not - we aren't going to mess with it lda FILSTA ; get tape file status cmpa #2 ; output file? bne L8285 ; brif not lda CINCTR ; is there anything waiting to be written out? bne L8285 ; brif so - mainline code will handle it properly clr DEVNUM ; reset output to screen leas 2,s ; don't return to mainline code jmp LA444 ; write EOF block ; RUN handler - sets up some Extended Basic stuff to defaults at program start XVEC18 ldd #0xba42 ; initialize PLAY volume std VOLHI lda #2 ; set PLAY tempo to 2, PLAY octave to 3 sta TEMPO sta OCTAVE asla ; set default note length to 5 sta NOTELN clr DOTVAL ; don't do any note length extension ldd ZERO ; initialize DRAW angle and scale to default 1 std ANGLE ldb #128 ; initialize horizontal and vertical default coordinates to the middle of the screen std HORDEF ldb #96 std VERDEF rts ; Command interpretation loop handler; we need to intercept this to implement TRON/TROFF XVEC20 leas 2,s ; don't return to the mainline code L82BB andcc #0xaf ; make sure interrupts are running jsr LADEB ; do a BREAK/pause check ldx CHARAD ; save input pointer stx TINPTR lda ,x+ ; get current input character beq L82CF ; brif end of line cmpa #': ; statement separator? beq L82F1 ; brif so jmp LB277 ; raise error we got here with extra junk L82CF lda ,x++ ; get first byte of next line address sta ENDFLG ; use it to set "END" flag to "END" bne L82D8 ; brif not end of program jmp LAE15 ; go do the "END" L82D8 ldd ,x+ ; get line number of next line (and leave pointer one before line text) std CURLIN ; set current line number stx CHARAD ; save input pointer lda TRCFLG ; are we tracing? beq L82F1 ; brif not lda #'[ ; show opening marker for TRON line number jsr PUTCHR lda CURLIN ; restore MSB of line number jsr LBDCC ; show line number lda #'] ; show closing marker for TRON line number jsr PUTCHR L82F1 jsr GETNCH ; get the start of the statement tfr cc,b ; save status flags cmpa #0x98 ; is it CSAVE? beq L8316 ; brif so - go to Extended Basic patch (adds CSAVEM) cmpa #0x97 ; is it CLOAD? beq L8311 ; brif so - go to Extended Basic patch (adds multi-origin binaries) tfr b,cc ; restore character status jsr LADC6 ; go process command bra L82BB ; restart interpretation loop ; Tokenizaton handler. This is actually a hack to intercept CLOAD and CSAVE during immediate mode by causing the ; tokenization routine to return to the interpretation loop above instead of the mainline interpretation loop. This ; is necessary because the first command encountered on a line in immediate mode is executed BEFORE the interpretation ; loop RAM hook is called. This patch doesn't actually affect tokenization itself at all. XVEC23 ldx 2,s ; get return address of caller to the tokenizer cmpx #LAC9D ; is it coming from immediate mode prior to executing the line? bne L8310 ; brif not ldx #L82F1 ; force return to Extended Basic's main loop patch above stx 2,s L8310 rts ; These two patches are set up this way so that control can be transferred back to the original Color Basic ; implementations if the Extended Basic addons are not triggered. L8311 jsr L8C62 ; transfer control to Extended Basic's CLOAD handler bra L82BB ; go do another command L8316 bsr L831A ; go do Extended Basic's CSAVE handler bra L82BB ; go do another command ; Extended Basic's CSAVE handler which implements CSAVEM (which Color Basic does not have) L831A jsr GETNCH ; get character after CSAVE cmpa #'M ; is it CSAVEM? lbne CSAVE ; brif not - Color Basic can handle this jsr GETNCH ; eat the "M" jsr LA578 ; parse file name bsr L836C ; get start address stx CASBUF+13 ; save it in file header bsr L836C ; get end address cmpx 2,s ; compare to start address lblo LB44A ; brif end address is before the start address bsr L836C ; get execution address stx CASBUF+11 ; put in file header jsr GETCCH ; are we at the end of the commmand? bne L8310 ; brif not lda #2 ; file type to machine language ldx ZERO ; set to binary and single block jsr LA65F ; write header clr FILSTA ; mark any open tape file closed inc BLKTYP ; set block type to data jsr WRLDR ; write a data leader ldx 4,s ; get starting address L834D stx CBUFAD ; set start of data address lda #255 ; try a full length block by default sta BLKLEN ldd 2,s ; get ending address subd CBUFAD ; see how much is left bhs L835E ; brif we have more to write leas 6,s ; clean up stack jmp LA491 ; write EOF block L835E cmpd #255 ; do we have a full block left? bhs L8367 ; brif so incb ; set block size to remainder stb BLKLEN L8367 jsr SNDBLK ; write a data block bra L834D ; go see if we have more to write L836C jsr SYNCOMMA ; make sure we have a comma jsr LB73D ; evaluate unsigned expression to X ldu ,s ; get return address stx ,s ; save result on stack tfr u,pc ; return to caller ; COS function COS ldx #L83AB ; point to PI/2 constant jsr LB9C2 ; add to argument ( cos(x) = sin((pi/2)+x) ) L837E jmp SIN ; now calculate sin((pi/2)+x) ; TAN function. This is determined by the identity TAN(X) = SIN(X)/COS(X) TAN jsr LBC2F ; save FPA0 in FPA3 clr RELFLG ; reset quadrant flag bsr L837E ; calculate SIN(x) ldx #V4A ; save result in FPA5 jsr LBC35 ldx #V40 ; get back original argument jsr LBC14 clr FP0SGN ; force result positive lda RELFLG ; get quadrant flag bsr L83A6 ; calculate COS(x) tst FP0EXP ; did we get 0 for COS(x) lbeq LBA92 ; brif so - overflow ldx #V4A ; point to sin(x) L83A3 jmp LBB8F ; divide the sin(x) value by the cos(x) value L83A6 pshs a ; save sign flag jmp LBFA6 ; expand polynomial L83AB fcb 0x81,0x49,0x0f,0xda,0xa2 ; pi/2 constant ; ATN function (inverse tangent). There are two calculation streams used to improve precision. ; One if the parameter is >= 1.0 and the other if it is < 1.0 ATN lda FP0SGN ; get sign of argument pshs a ; save it bpl L83B8 ; brif positive bsr L83DC ; flip sign of argument L83B8 lda FP0EXP ; get exponent pshs a ; save it cmpa #0x81 ; exponent for 1.0 blo L83C5 ; brif less - value is less than 1.0 ldx #LBAC5 ; point to FP constant 1.0 bsr L83A3 ; calculate reciprocal L83C5 ldx #L83E0 ; point to polynomical coefficients jsr LBEF0 ; expand polynomial puls a ; get exponent of argument cmpa #0x81 ; did we do a reciprocal calculation? blo L83D7 ; brif not ldx #L83AB ; subtract result from pi/2 if we did jsr LB9B9 L83D7 puls a ; get sign of original tsta ; was it positive? bpl L83DF ; brif so L83DC jmp LBEE9 ; flip sign of result L83DF rts ; Chebyshev modified taylor series coefficients for inverse tangent. Note that these diverge quite significantly ; from the standard taylor series after 1/9. The standard coefficients are 1/1,-1/3, 1/5, -1/7, 1/9, -1/11, and ; so on. These modified coefficients yield reasonable accuracy for the precision available, presumably with ; fewer coefficients. L83E0 fcb 11 ; 12 coefficients fcb 0x76,0xb3,0x83,0xbd,0xd3 ; -0.000684793912 fcb 0x79,0x1e,0xf4,0xa6,0xf5 ; 0.00485094216 fcb 0x7b,0x83,0xfc,0xb0,0x10 ; -0.0161117018 fcb 0x7c,0x0c,0x1f,0x67,0xca ; 0.0342096381 fcb 0x7c,0xde,0x53,0xcb,0xc1 ; -0.0542791328 fcb 0x7d,0x14,0x64,0x70,0x4c ; 0.0724571965 fcb 0x7d,0xb7,0xea,0x51,0x7a ; -0.0898023954 fcb 0x7d,0x63,0x30,0x88,0x7e ; 0.110932413 fcb 0x7e,0x92,0x44,0x99,0x3a ; -0.142839808 fcb 0x7e,0x4c,0xcc,0x91,0xc7 ; 0.199999121 fcb 0x7f,0xaa,0xaa,0xaa,0x13 ; -0.333333316 fcb 0x81,0x00,0x00,0x00,0x00 ; 1.0 ; Chebyshev modified taylor series coefficients for the ln(x)/ln(2) (base 2 log of x) L841D fcb 3 ; four coefficients fcb 0x7f,0x5e,0x56,0xcb,0x79 ; 0.434255942 from (2/7)/ln(2) fcb 0x80,0x13,0x9b,0x0b,0x64 ; 0.576584541 from (2/5)/ln(2) fcb 0x80,0x76,0x38,0x93,0x16 ; 0.961800759 from (2/3)/ln(2) fcb 0x82,0x38,0xaa,0x3b,0x20 ; 2.88539007 from 2/ln(2) L8432 fcb 0x80,0x35,0x04,0xf3,0x34 ; 1/sqrt(2) L8437 fcb 0x81,0x35,0x04,0xf3,0x34 ; sqrt(2) L843C fcb 0x80,0x80,0x00,0x00,0x00 ; -0.5 L8441 fcb 0x80,0x31,0x72,0x17,0xf8 ; ln(2) ; LOG function (natural log, ln) ; FP representation is of the form A*2^B. Thus, the log routine determines the value of ; ln(A*2^B). ; ; ln(A*2^B) = ln(A) + ln(2^B) = ln(A) + B*ln(2) = (ln(A)/ln(2) + B)*ln(2), OR: ; (log2(A) + B)*ln(2) ; Now if we write A as A*(sqrt(2)/sqrt(2)), we haven't changed anything so: ; (log2(A*sqrt(2)/sqrt(2)) + B)*ln(2) = (log2(A*sqrt(2)) - log2(sqrt(2)) + B) * ln(2) ; which gives: (-1/2 + log2(A*sqrt(2)) + B) * ln(2) ; ; Everything except log2(A*sqrt(2)) is either constant or trivial. ; ; What the actual code below feeds into the modified taylor series is actually: ; 1 - (sqrt(2)/(A + sqrt(2)) which algebra reveals to be (A*sqrt(2)-1)/(A*sqrt(2)+1) ; ; Thus, the code is using (A*sqrt(2)-1)/(A*sqrt(2)+1) instead of A*sqrt(2) as one would ; expect from the identities. However, the modified coefficients in the series above ; could be correcting for that or the introduced error was deemed acceptable. ; NOTE: this routine does NOT return 0 for LOG(1) LOG jsr LBC6D ; get status of FPA0 lble LB44A ; brif <= 0 - logarithms don't exist in that case ldx #L8432 ; point to 1/sqrt(2) lda FP0EXP ; get exponent of argument suba #0x80 ; remove bias pshs a ; save it for later lda #0x80 ; force exponent to 0 (this turns FPA0 into A in the above description) sta FP0EXP jsr LB9C2 ; add 1/sqrt(2) to A ldx #L8437 ; point to sqrt(2) jsr LBB8F ; divide that by FPA0 ldx #LBAC5 ; point to 1.0 jsr LB9B9 ; subtract result from 1.0: Now FPA0 is 1-(sqrt(2)/(A+1/sqrt(2))) ldx #L841D ; point to coefficients jsr LBEF0 ; expand polynomial (calculate base 2 log of modified argument) ldx #L843C ; point to -0.5 jsr LB9C2 ; add result puls b ; get original exponent back jsr LBD99 ; add B to FPA0 ldx #L8441 ; point to ln(2) jmp LBACA ; multiply by ln(2) which gives us the result in base e ; SQR function (square root) - returns the principle root (positive) SQR jsr LBC5F ; move argument to FPA1 (first argument for exponentiation) ldx #LBEC0 ; point to 0.5 (exponent for square root) jsr LBC14 ; set up second argument to exponentiation (the exponent) ; Exponentiation operator ; This is calculated as A^x = e^(x*ln(A)) where A is in FPA1 and x is in FPA0 L8489 beq EXP ; do "EXP" if exponent is 0 (this will catch 0^0) tsta ; check that the base is not 0 bne L8491 ; brif base is not 0 jmp LBA3A ; 0^(nonzero) is 0 L8491 ldx #V4A ; save exponent (to FPA5) jsr LBC35 clrb ; result sign will default to positive lda FP1SGN ; check if base is positive bpl L84AC ; brif so jsr INT ; convert exponent to integer ldx #V4A ; point to original expoent lda FP1SGN ; get sign of FPA1 jsr LBCA0 ; compare original exponent with truncated one bne L84AC ; brif not equal coma ; flip sign ldb CHARAC ; get LS byte of integer exponent (result sign flag) L84AC jsr LBC4C ; copy FPA1 (base) to FPA0 (A = sign) pshs b ; save result sign jsr LOG ; get natural log of the base ldx #V4A ; multiply the log by the exponent jsr LBACA bsr EXP ; now raise e to the resulting power puls a ; get result sign rora ; brif it was negative lbcs LBEE9 ; brif negative - flip sign rts L84C4 fcb 0x81,0x38,0xaa,0x3b,0x29 ; 1.44269504 (correction factor for exponential function) ; Chebyshev modified taylor series coefficients for e^x L84C9 fcb 7 ; eight coefficients fcb 0x71,0x34,0x58,0x3e,0x56 ; 1/(7!*(CF^7)) fcb 0x74,0x16,0x7e,0xb3,0x1b ; 1/(6!*(CF^6)) fcb 0x77,0x2f,0xee,0xe3,0x85 ; 1/(5!*(CF^5)) fcb 0x7a,0x1d,0x84,0x1c,0x2a ; 1/(4!*(CF^4)) fcb 0x7c,0x63,0x59,0x58,0x0a ; 1/(3!*(CF^3)) fcb 0x7e,0x75,0xfd,0xe7,0xc6 ; 1/(2!*(CF^2)) fcb 0x80,0x31,0x72,0x18,0x10 ; 1/(1!*(CF^1)) fcb 0x81,0x00,0x00,0x00,0x00 ; 1 ; EXP function (e^x) EXP ldx #L84C4 ; point to correction factor jsr LBACA ; multiply it jsr LBC2F ; save corrected argument to FPA3 lda FP0EXP ; get exponent of FPA0 cmpa #0x88 ; is it too big? blo L8504 ; brif not L8501 jmp LBB5C ; to 0 (underflow) or overflow error L8504 jsr INT ; convert argument to an integer lda CHARAC ; get ls byte of integer adda #0x81 ; was argument 127? if so, the OV error; adds bias beq L8501 deca ; adjust for the extra +1 above pshs a ; save integer exponent ldx #V40 ; get fractional part of argument jsr LB9B9 ldx #L84C9 ; point to coefficients jsr LBEFF ; evaluate polynomial on the fractional part clr RESSGN ; force result to be positive puls a ; get back original exponent jsr LBB48 ; add original exponent to the fractional result rts ; FIX function (truncate/round toward 0) (NOTE: INT() always rounds down so INT(-0.5) gives -1 but FIX(-0.5) gives 0) FIX jsr LBC6D ; get status of argument bmi L852C ; brif negative L8529 jmp INT ; do regular "int" if positive L852C com FP0SGN ; flip the sign bsr L8529 ; do "INT" on this jmp LBEE9 ; flip the sign back ; EDIT command EDIT jsr L89AE ; get line number leas 2,s ; we're not going to return to the main loop L8538 lda #1 ; "LIST" flag sta VD8 ; set to list the line jsr LAD01 ; find line number lbcs LAED2 ; brif line wasn't found jsr LB7C2 ; go unpack the line into the buffer tfr y,d ; calculate the actual length of the line subd #LINBUF+2 stb VD7 ; save line length (it will only be 8 bits) L854D ldd BINVAL ; get the line number jsr LBDCC ; display it jsr LB9AC ; put a space after it ldx #LINBUF+1 ; point to iput uffer ldb VD8 ; are we listing? bne L8581 ; brif so L855C clrb ; reset digit accumulator L855D jsr L8687 ; get a keypress jsr L90AA ; set carry if not numeric bcs L8570 ; brif not a number suba #'0 ; remove ASCII bias pshs a ; save digit value lda #10 ; multiply accumulator by 10 mul addb ,s+ ; add in new digit bra L855D ; go check for another digit L8570 subb #1 ; this converts 0 to 1, but *only* 0 to 1 adcb #1 cmpa #'A ; abort? bne L857D ; brif not jsr LB958 ; to a CR bra L8538 ; restart EDIT process L857D cmpa #'L ; list? bne L858C ; brif not L8581 bsr L85B4 ; list the line clr VD8 ; reset to "not listing" jsr LB958 ; do a CR bra L854D ; start editing L858A leas 2,s ; lose return address L858C cmpa #0x0d ; ENTER? bne L859D ; brif not bsr L85B4 ; echo out the line L8592 jsr LB958 ; do a CR ldx #LINBUF+1 ; reset input pointer to start of buffer stx CHARAD jmp LACA8 ; join immediate mode to replace the line in the program L859D cmpa #'E ; exit? beq L8592 ; brif so - end edit with no echo cmpa #'Q ; quit? bne L85AB ; brif not jsr LB958 ; do a CR jmp LAC73 ; go to immediate mode with no fanfare - no changes saved L85AB bsr L85AF ; go do commands bra L855C ; go handle another command L85AF cmpa #0x20 ; space? bne L85C3 ; brif not skip2 L85B4 ldb #LBUFMX-1 ; display up to a whole line L85B6 lda ,x ; get buffer chracter beq L85C2 ; brif end of line jsr PUTCHR ; output character leax 1,x ; move to next character decb ; done? bne L85B6 ; brif not L85C2 rts L85C3 cmpa #'D ; delete? bne L860F ; brif not L85C7 tst ,x ; end of line? beq L85C2 ; brif so - can't delete bsr L85D1 ; remove a character decb ; done all requested? bne L85C7 ; brif not rts L85D1 dec VD7 ; account for character being removed leay -1,x ; set pointer and compensate for increment below L85D5 leay 1,y ; move to next character lda 1,y ; get next character sta ,y ; move it forward bne L85D5 ; brif we didn't hit the end of the buffer rts L85DE cmpa #'I ; insert? beq L85F5 ; brif so cmpa #'X ; extend? beq L85F3 ; brif so cmpa #'H ; "hack"? bne L8646 ; brif not clr ,x ; mark current location as end of line tfr x,d ; calculate new line length subd #LINBUF+2 stb VD7 ; save new length L85F3 bsr L85B4 ; display the line L85F5 jsr L8687 ; read a character cmpa #0x0d ; ENTER? beq L858A ; brif so - terminate entry cmpa #0x1b ; ESC? beq L8625 ; brif so - back to command mode cmpa #0x08 ; backspace? bne L8626 ; brif no cmpx #LINBUF+1 ; are we at the start of the buffer? beq L85F5 ; brif so - it's a no-op bsr L8650 ; move pointer back one, do a BS bsr L85D1 ; remove character from the buffer bra L85F5 ; go handle more input L860F cmpa #'C ; change? bne L85DE ; brif not L8613 tst ,x ; is there something to change? beq L8625 ; brif not jsr L8687 ; get a key stroke bcs L861E ; brif valid key bra L8613 ; try again if invalid key L861E sta ,x+ ; put new character in the buffer bsr L8659 ; echo it decb ; changed number requested? bne L8613 ; brif not L8625 rts L8626 ldb VD7 ; get length of line cmpb #LBUFMX-1 ; at maximum line length? bne L862E ; brif not bra L85F5 ; process another input character L862E pshs x ; save input pointer L8630 tst ,x+ ; are we at the end of the line? bne L8630 ; brif not L8634 ldb ,-x ; get character before current pointer, move back stb 1,x ; move it forward cmpx ,s ; at the original buffer pointer? bne L8634 ; brif not leas 2,s ; remove saved buffer pointer sta ,x+ ; save input character in newly made hole bsr L8659 ; echo it inc VD7 ; bump line length counter bra L85F5 ; go handle more stuff L8646 cmpa #0x08 ; backspace? bne L865C ; brif not L864A bsr L8650 ; move pointer back, echo BS decb ; done enough of them? bne L864A ; brif not rts L8650 cmpx #LINBUF+1 ; at start of buffer? beq L8625 ; brif so leax -1,x ; move pointer back lda #0x08 ; character to echo - BS L8659 jmp PUTCHR ; echo character to screen L865C cmpa #'K ; "kill"? beq L8665 ; brif so suba #'S ; search? beq L8665 ; brif so rts L8665 pshs a ; save kill/search flag bsr L8687 ; read target pshs a ; save search character L866B lda ,x ; get current character in buffer beq L8685 ; brif end of line - nothing more to search tst 1,s ; is it KILL? bne L8679 ; brif so bsr L8659 ; echo the character leax 1,x ; move ahead bra L867C ; check next character L8679 jsr L85D1 ; remove character from buffer L867C lda ,x ; get character in buffer cmpa ,s ; are we at the target? bne L866B ; brif not decb ; have we found enough of them? bne L866B ; brif not L8685 puls y,pc ; clean up stack and return to main EDIT routine L8687 jsr LA171 ; get input from the generic input handler (will show the cursor) cmpa #0x7f ; graphics (or DEL)? bhs L8687 ; brif so - ignore it cmpa #0x5f ; SHIFT-UP? bne L8694 ; brif not lda #0x1b ; replace with ESC L8694 cmpa #0x0d ; carriage return? beq L86A6 ; brif so (C=0) cmpa #0x1b ; ESC beq L86A6 ; brif so (C=0) cmpa #0x08 ; backspace? beq L86A6 ; brif so (C=0) cmpa #32 ; control code? blo L8687 ; brif control code - try again orcc #1 ; set C for "valid" (printable) character L86A6 rts ; TRON and TROFF commands TRON skip1lda ; load flag with nonzero for trace enabled (and skip next) TROFF clra ; clear flag for trace disabled sta TRCFLG ; save trace status rts ; POS function POS lda DEVNUM ; get original device number pshs a ; save it for later jsr LA5AE ; fetch device number jsr LA406 ; check for open file jsr LA35F ; set up print parameters ldb DEVPOS ; get current line position for the device jmp LA5E4 ; return position in B as unsigned ; VARPTR function VARPTRTOK jsr LB26A ; make sure we have ( ldd ARYEND ; get address of end of arrays pshs d ; save it jsr LB357 ; parse variable descriptor jsr LB267 ; make sure there is a ) puls d ; get original end of arrays exg x,d ; swap original end of arrays and the discovered variable pointer cmpx ARYEND ; did array end move (variable created?) bne L8724 ; brif so (FC error) jmp GIVABF ; return the pointer (NOTE: as signed) ; MID$() assignment; note that this cannot make the string longer or shorter and if the replacement is shorter ; than the specified size, only the number of characters actually in the replacement will be used. L86D6 jsr GETNCH ; eat the MID$ token jsr LB26A ; force ( jsr LB357 ; evaluate the variable pshs x ; save variable descriptor ldd 2,x ; point to start of original string cmpd FRETOP ; is it in string space? bls L86EB ; brif not subd MEMSIZ ; is it still in string space (top end)? bls L86FD ; brif so L86EB ldb ,x ; get length of original string jsr LB56D ; allocate space in string space pshs x ; save pointer to string space ldx 2,s ; get to original string descriptor jsr LB643 ; move the string into string space puls x,u ; get new string address and string descriptor stx 2,u ; save new data address for the string pshs u ; save descriptor address again L86FD jsr LB738 ; evaluate ",start" pshs b ; save start offset tstb ; is start 0? beq L8724 ; brif so - strings offsets are 1-based ldb #255 ; default use the entire string cmpa #') ; end of parameters? beq L870E ; brif so jsr LB738 ; evaluate ",length" L870E pshs b ; save length jsr LB267 ; make sure we have a ) ldb #0xb3 ; make sure we have = jsr LB26F bsr L8748 ; evaluate replacement string tfr x,u ; save replacement string address ldx 2,s ; get original string descriptor lda ,x ; get length of original string suba 1,s ; subtract start position bhs L8727 ; brif within the string - insert replacement L8724 jmp LB44A ; raise illegal function call L8727 inca ; A is now number of characters to the right of the position parameter cmpa ,s ; compare to length desired bhs L872E ; brif new length fits sta ,s ; only use as much of the length as will fit L872E lda 1,s ; get position offset exg a,b ; swap replacement length and position ldx 2,x ; point to original string address decb ; we work with 0-based offsets abx ; now X points to start of replacement tsta ; replacing 0? beq L8746 ; brif so - done cmpa ,s ; is replacement shorter than the hole? bls L873F ; brif so lda ,s ; use copy the maximum number specified L873F tfr a,b ; save number to move in B exg u,x ; swap pointers so they are right for the routine jsr LA59A ; copy string data L8746 puls a,b,x,pc ; clean up stack and return L8748 jsr LB156 ; evaluate expression jmp LB654 ; make sure it's a string and return string details ; STRING$ function STRING jsr LB26A ; make sure we have ( jsr EVALEXPB ; evaluate repeat count (error if > 255) pshs b ; save repeat count jsr SYNCOMMA ; make sure there's a comma jsr LB156 ; evaluate the thing to repeat jsr LB267 ; make sure we have a ) lda VALTYP ; is it string? bne L8768 ; brif so jsr LB70E ; get 8 bit character code bra L876B ; use that L8768 jsr LB6A4 ; get first character of string L876B pshs b ; save repeat character ldb 1,s ; get repeat count jsr LB50F ; reserve space for the string puls a,b ; get character and repeat count beq L877B ; brif NULL string L8776 sta ,x+ ; put character into string decb ; put enough? bne L8776 ; brif not L877B jmp LB69B ; return the newly created string ; INSTR function INSTR jsr LB26A ; evaluate ( jsr LB156 ; evaluate first argument ldb #1 ; default start position is 1 (start of string) pshs b ; save start position lda VALTYP ; get type of first argument bne L879C ; brif string - use default starting position jsr LB70E ; convert first argument into string offset stb ,s ; save offset beq L8724 ; brif starting at 0 - not allowed jsr SYNCOMMA ; make sure there's a comma jsr LB156 ; evaluate the search string jsr LB146 ; make sure it *is* a string L879C ldx FPA0+2 ; get search string descriptor pshs x ; save it jsr SYNCOMMA ; make sure we have a comma jsr L8748 ; evalute the target string pshs x,b ; save address and length of target string jsr LB267 ; make sure we have a ) ldx 3,s ; get search string address jsr LB659 ; get string details pshs b ; save search string length cmpb 6,s ; compare length of search string to the start blo L87D9 ; brif start position is beyond the search string - return 0 lda 1,s ; get length of target string beq L87D6 ; brif targetstring is NULL - match will be immediate ldb 6,s ; get start position decb ; zero-base it abx ; now X points to the start position for the search L87BE leay ,x ; point to start of search ldu 2,s ; get target string pointer ldb 1,s ; get targetlength lda ,s ; get length of serach suba 6,s ; see how much is left in searh inca ; add one for "inclusivity" cmpa 1,s ; do we have less than the target string? blo L87D9 ; brif so - we obviously won't match L87CD lda ,x+ ; compare a byte cmpa ,u+ bne L87DF ; brif no match decb ; compared all of target? bne L87CD ; brif not L87D6 ldb 6,s ; get position where we matched skip1 L87D9 clrb ; flag no match leas 7,s ; clean up stack jmp LB4F3 ; return unsigned B L87DF inc 6,s ; bump start position leax 1,y ; move starting pointer bra L87BE ; see if we match now ; Number parsing handler XVEC19 cmpa #'& ; do we have & (hex or octal)? bne L8845 ; brif not leas 2,s ; we won't return to the original invoker L87EB clr FPA0+2 ; clear bottom of FPA0 for 16 bit value clr FPA0+3 ldx #FPA0+2 ; point to accumulator jsr GETNCH ; eat the & cmpa #'O ; octal? beq L880A ; brif so cmpa #'H ; hex? beq L881F ; brif so jsr GETCCH ; reset flags on input bra L880C ; go process octal (default) L8800 cmpa #'8 ; is it a valid octal character? lbhi LB277 ; brif not (BUG: should be LBHS or above be #'7) ldb #3 ; base 8 multiplier bsr L8834 ; add digit to accumulator L880A jsr GETNCH ; get input character L880C bcs L8800 ; brif numeric L880E clr FPA0 ; clear upper bytes of FPA0 clr FPA0+1 clr VALTYP ; result is numeric clr FPSBYT ; clear out any extra precision clr FP0SGN ; make it positive ldb #0xa0 ; exponent for integer aligned to right of FPA0 stb FP0EXP jmp LBA1C ; go normalize the result and return L881F jsr GETNCH ; get input character bcs L882E ; brif digit jsr LB3A2 ; set carry if not alpha L8826 bcs L880E ; brif not alpha cmpa #'G ; is it valid HEX digit? bhs L880E ; brif not suba #7 ; normalize A-F to be just above 0-9 L882E ldb #4 ; four bits per digit bsr L8834 ; add digit to accumlator bra L881F ; process another digit L8834 asl 1,x ; shift accumulator one bit left rol ,x lbcs LBA92 ; brif too big - overflow decb ; done enough bit shifts? bne L8834 ; brif not L883F suba #'0 ; remove ASCII bias adda 1,x ; merge digit into accumlator (this cannot cause carry) sta 1,x L8845 rts ; Expression evaluation handler XVEC15 puls u ; get back return address clr VALTYP ; set result to numeric ldx CHARAD ; save input pointer jsr GETNCH ; get the input character cmpa #'& ; HEX or OCTAL? beq L87EB ; brif so cmpa #0xcc ; FN? beq L88B4 ; brif so - do "FNx()" cmpa #0xff ; function token? bne L8862 ; brif not jsr GETNCH ; get function token value cmpa #0x83 ; USR? lbeq L892C ; brif so - short circuit Color Basic's USR handler L8862 stx CHARAD ; restore input pointer jmp ,u ; return to mainline code L8866 ldx CURLIN ; are we in immediate mode? leax 1,x bne L8845 ; brif not - we're good ldb #2*11 ; code for illegal direct statement L886E jmp LAC46 ; raise error ; DEF command (DEF FN, DEF USR) DEF ldx [CHARAD] ; get two input characters cmpx #0xff83 ; USR? lbeq L890F ; brif so - do DEF USR bsr L88A1 ; get descriptor address for FN variable bsr L8866 ; disallow DEF FN in immediate mode jsr LB26A ; make sure we have ( ldb #0x80 ; disallow arrays as arguments stb ARYDIS jsr LB357 ; evaluate variable bsr L88B1 ; make sure it's numeric jsr LB267 ; make sure we have ) ldb #0xb3 ; make sure we have = jsr LB26F ldx V4B ; get variable descriptor address ldd CHARAD ; get input pointer std ,x ; save address of the actual function code in variable descriptor ldd VARPTR ; get descriptor address of argument std 2,x ; save argument descriptor address jmp DATA ; move to the end of this statement L88A1 ldb #0xcc ; make sure we have FN jsr LB26F ldb #0x80 ; disable array lookup stb ARYDIS ora #0x80 ; set bit 7 of first character (to indicate FN variable) jsr LB35C ; find the variable stx V4B ; save descriptor pointer L88B1 jmp LB143 ; make sure we have a numeric variable ; Evaluate an FN call L88B4 bsr L88A1 ; parse the FNx bit and get the descriptor pshs x ; save descriptor jsr LB262 ; evaluate parameter bsr L88B1 ; make sure it's a number puls u ; get FN descriptor ldb #2*25 ; code for undefined function ldx 2,u ; point to argument variable descriptor beq L886E ; brif nothing doing there (if it was just created, this will be NULL) ldy CHARAD ; save current input pointer ldu ,u ; point to start of FN definition stu CHARAD ; put input pointer there lda 4,x ; save original value of argument and save it with current input, and variable pointers pshs a ldd ,x ldu 2,x pshs u,y,x,d jsr LBC35 ; set argument variable to the argument L88D9 jsr LB141 ; go evaluate the FN expression puls d,x,y,u ; get back variable pointers, input pointer, and original variable value std ,x stu 2,x puls a sta 4,x jsr GETCCH ; test end of FN formula lbne LB277 ; brif not end of statement - problem with the function sty CHARAD ; restore input pointer L88EF rts ; Error handler XVEC17 cmpb #2*25 ; is it a valid Extended Basic error code? blo L88EF ; brif not - return to mainline jsr LA7E9 ; turn off tape jsr LA974 ; turn off sound jsr LAD33 ; clean up stack and other bits clr DEVNUM ; reset output to screen jsr LB95C ; do a newline if needed jsr LB9AF ; do a ? ldx #L890B-25*2 ; point to error message table jmp LAC60 ; go display error message ; Extended Basic error codes. Yes, NE is defined here even though it is only actually documented in the ; Disk Basic documentation. It is here for the use of DLOAD. L890B fcc 'UF' ; 25 undefined function call fcc 'NE' ; 26 File not found ; DEF USR L890F jsr GETNCH ; eat the USR token bsr L891C ; get pointer to USR call pshs x ; save FN exec address location bsr L8944 ; calculate execution address puls u ; get FN address pointer stx ,u ; save new address rts L891C clrb ; default routine number is 0 jsr GETNCH ; fetch the call number bcc L8927 ; brif not a number suba #'0 ; remove ASCII bias tfr a,b ; save it in the right place jsr GETNCH ; eat the call number L8927 ldx USRADR ; get start address of USR jump table aslb ; two bytes per address abx ; now X points to the right entry rts ; Evaluate a USR call L892C bsr L891C ; find the correct routine address location ldx ,x ; get routine address pshs x ; save it jsr LB262 ; evaluate argument ldx #FP0EXP ; point to FPA0 (argument value) lda VALTYP ; is it string? beq L8943 ; brif not jsr LB657 ; fetch string details (removes it from the string stack) ldx FPA0+2 ; get string descriptor pointer lda VALTYP ; set flags for the value type L8943 rts ; call the routine and return to mainline code L8944 ldb #0xb3 ; check for "=" jsr LB26F jmp LB73D ; evaluate integer expression to X and return ; Extended Basic IRQ handler XIRQSV lda PIA0+3 ; is it VSYNC interrupt? bmi L8952 ; brif so rti ; really should clear the HSYNC interrupt here L8952 lda PIA0+2 ; clear VSYNC interrupt ldx TIMVAL ; increment the TIMER value leax 1,x stx TIMVAL jmp L9C3E ; check for other stuff ; TIMER= L8960 jsr GETNCH ; eat the TIMER token bsr L8944 ; evaluate =nnnn to X stx TIMVAL ; set the timer rts ; TIMER function TIMER ldx TIMVAL ; get timer value stx FPA0+2 ; set it in FPA0 jmp L880E ; return as positive 16 bit value ; DEL command DEL lbeq LB44A ; raise error if no argument (probably to avoid accidentally deleting line 0) jsr LAF67 ; parse line number jsr LAD01 ; find line stx VD3 ; save address of line jsr GETCCH ; is there something more? beq L8990 ; brif not cmpa #0xac ; dash? bne L89BF ; brif not - error out jsr GETNCH ; each the - beq L898C ; brif no ending line - use default line number bsr L89AE ; parse second line number and save in BINVAL bra L8990 ; do the deletion L898C lda #0xff ; set to maximum line number sta BINVAL L8990 ldu VD3 ; point end to start skip2 L8993 ldu ,u ; point to start of next line ldd ,u ; check for end of program beq L899F ; brif end of program ldd 2,u ; get line number subd BINVAL ; is it in range? bls L8993 ; brif so L899F ldx VD3 ; get starting line address bsr L89B8 ; close up gap jsr LAD21 ; reset input pointer and erase variables ldx VD3 ; get start of program after the deletion jsr LACF1 ; recompute netl ine pointers jmp LAC73 ; return to immediate mode L89AE jsr LAF67 ; parse a line number jmp LA5C7 ; make sure there's nothing more L89B4 lda ,u+ ; copy a byte sta ,x+ L89B8 cmpu VARTAB ; end of program? bne L89B4 ; brif not stx VARTAB ; save new start of variables/end of program L89BF rts ; LINE INPUT L89C0 jsr L8866 ; raise error if in immediate mode jsr GETNCH ; eat the "INPUT" token cmpa #'# ; device number? bne L89D2 ; brif not jsr LA5A5 ; parse device number jsr LA3ED ; make sure it's valid for input jsr SYNCOMMA ; make sure there's a comma after the device number L89D2 cmpa #'" ; is there a prompt? bne L89E1 ; brif not jsr LB244 ; parse the string ldb #'; ; make sure there's a semicolon after the prompt jsr LB26F jsr LB99F ; go actually display the prompt L89E1 leas -2,s ; make a hole on the stack (so number of return adddresses is right) jsr LB035 ; read an input line from current device leas 2,s ; clean up stack clr DEVNUM ; reset to screen/keyboard jsr LB357 ; parse a variable stx VARDES ; save pointer to it jsr LB146 ; make sure it's a string ldx #LINBUF ; point to input buffer clra ; make sure we terminate on NUL only jsr LB51A ; parse string and store it in string space jmp LAFA4 ; go assign the string to its final resting place ; RENUM command L89FC jsr LAF67 ; read a line number ldx BINVAL ; get value rts L8A02 ldx VD1 ; get current old number being renumbered L8A04 stx BINVAL ; save number being searched for jmp LAD01 ; go find line number RENUM jsr LAD26 ; erase variables ldd #10 ; default line number interval and start std VD5 ; set starting line number std VCF ; set number interval clrb ; now D is 0 std VD1 ; save default start for renumbering jsr GETCCH ; are there any arguments bcc L8A20 ; brif not numeric bsr L89FC ; fetch line number stx VD5 ; save line beginning number jsr GETCCH ; get input character L8A20 beq L8A3D ; brif end of line jsr SYNCOMMA ; make sure we have a comma bcc L8A2D ; brif next isn't numeric bsr L89FC ; fetch starting line number stx VD1 ; save the number where we start working jsr GETCCH ; fetch input character L8A2D beq L8A3D ; brif end of line jsr SYNCOMMA ; make sure we have a comma bcc L8A3A ; brif we don't have a number bsr L89FC ; parse the number stx VCF ; save interval beq L8A83 ; brif we ave a zero interval L8A3A jsr LA5C7 ; raise error if more stuff L8A3D bsr L8A02 ; get address of old number to process stx VD3 ; save address ldx VD5 ; get the next renumbered line to use bsr L8A04 ; find that line cmpx VD3 ; is it before the previous one? blo L8A83 ; brif so - raise error bsr L8A67 ; make sure renumbered line numbers will be in range jsr L8ADD ; convert line numbers to "expanded" binary jsr LACEF ; recalculate next line pointers bsr L8A02 ; get address of first line to renumber stx VD3 ; save it bsr L8A91 ; make sure line numbers exist bsr L8A68 ; renumber the actual lines bsr L8A91 ; update line numbers in program text jsr L8B7B ; convert packed binary line numbers to text jsr LAD26 ; erase variables, reset stack, etc. jsr LACEF ; recalculate next line pointers jmp LAC73 ; bounce back to immediate mode L8A67 skip1lda ; set line number flag to nonzero (skip next instruction) L8A68 clra ; set line number flag to zero (insert new numbers) sta VD8 ; save line number flag ldx VD3 ; get address of line being renumbered ldd VD5 ; get the current renumbering number bsr L8A86 ; return if end of program L8A71 tst VD8 ; test line number flag bne L8A77 ; brif not adding new numbers std 2,x ; set new number L8A77 ldx ,x ; point to next line bsr L8A86 ; return if end of program addd VCF ; add interval to current number bcs L8A83 ; brif we overflowed - bad line number cmpa #MAXLIN ; maximum legal number? blo L8A71 ; brif so - do another L8A83 jmp LB44A ; raise FC error L8A86 pshs d ; save D (we're going to clobber it) ldd ,x ; get next line pointer puls d ; unclobber D bne L8A90 ; brif not end of program leas 2,s ; return to caller's caller L8A90 rts L8A91 ldx TXTTAB ; get start of program leax -1,x ; move pointer back one (compensate for leax 1,x below) L8A95 leax 1,x ; move to next line bsr L8A86 ; return if end of program L8A99 leax 3,x ; move past next line address and line number, go one before line L8A9B leax 1,x ; move to next character lda ,x ; check input character beq L8A95 ; brif end of line stx TEMPTR ; save current pointer deca ; is it start of packed numeric line number? beq L8AB2 ; brif so deca ; does line exist? beq L8AD3 ; brif line number exists deca ; not part of something to process? bne L8A9B ; brif so L8AAC lda #3 ; set 1st byte to 3 to indicate line number not existing sta ,x+ bra L8A99 ; go process another L8AB2 ldd 1,x ; get MSB of line number dec 2,x ; is MS byte zero? beq L8AB9 ; brif not clra ; set MS byte to 0 L8AB9 ldb 3,x ; get LSB of line number dec 4,x ; is it zero? beq L8AC0 ; brif not clrb ; clear byte L8AC0 std 1,x ; save binary number std BINVAL ; save trial number jsr LAD01 ; find the line number L8AC7 ldx TEMPTR ; get start of packed line bcs L8AAC ; brif line number not found ldd V47 ; get address of line number inc ,x+ ; bump first byte to 2 (exists if checking) or 1 if inserting std ,x ; save address of correct number bra L8A99 ; go process more L8AD3 clr ,x ; clear carry and first byte ldx 1,x ; point to address of correct line ldx 2,x ; get correct line number stx V47 ; save it bra L8AC7 ; insert into line L8ADD ldx TXTTAB ; get beginning of program bra L8AE5 L8AE1 ldx CHARAD ; get input pointer leax 1,x ; move it forward L8AE5 bsr L8A86 ; return if end of program leax 2,x ; move past line address L8AE9 leax 1,x ; move forward L8AEB stx CHARAD ; save input pointer L8AED jsr GETNCH ; get an input character L8AEF tsta ; is it actual 0? beq L8AE1 ; brif end of line bpl L8AED ; brif not a token ldx CHARAD ; get input pointer cmpa #0xff ; function? beq L8AE9 ; brif so - ignore it (and following byte) jsr RVEC22 ; do the RAM hook thing cmpa #0xa7 ; THEN? beq L8B13 ; brif so cmpa #0x84 ; ELSE? beq L8B13 ; brif so cmpa #0x81 ; GO(TO|SUB)? bne L8AED ; brif not - we don't have a line number jsr GETNCH ; get TO/SUB cmpa #0xa5 ; GOTO? beq L8B13 ; brif so cmpa #0xa6 ; GOSUB? bne L8AEB ; brif not L8B13 jsr GETNCH ; fetch character after token bcs L8B1B ; brif numeric (line number) L8B17 jsr GETCCH ; set flags on input character bra L8AEF ; keep checking for line numbers L8B1B ldx CHARAD ; get input pointer pshs x ; save it jsr LAF67 ; parse line number ldx CHARAD ; get input pointer after line L8B24 lda ,-x ; get character before pointer jsr L90AA ; set C if numeric bcs L8B24 ; brif not numeric leax 1,x ; move pointer up tfr x,d ; calculate size of line number subb 1,s subb #5 ; make sure at least 5 bytes beq L8B55 ; brif exactly 5 bytes - no change blo L8B41 ; brif less than 5 bytes leau ,x ; move remainder of program backward negb ; negate extra number of bytes (to subtract from X) leax b,x ; now X is the correct position to move program to jsr L89B8 ; shift program backward bra L8B55 L8B41 stx V47 ; save end of line number space (end of copy) ldx VARTAB ; get end of program stx V43 ; set source pointer negb ; get positive difference leax b,x ; now X is the top of the destination block stx V41 ; set copy destination stx VARTAB ; save new end of program jsr LAC1E ; make sure enough room and make a hole in the program ldx V45 ; get end address of destination block stx CHARAD ; set input there L8B55 puls x ; get starting address of the line number lda #1 ; set "new number" flag sta ,x sta 2,x sta 4,x ldb BINVAL ; get MS byte of line number bne L8B67 ; brif it is not zero ldb #1 ; set to 1 if MSB is 0 inc 2,x ; flag MSB as 0 L8B67 stb 1,x ; set MSB of line number ldb BINVAL+1 ; get LSB of number bne L8B71 ; brif nonzero ldb #1 ; set to 1 if LSB is 0 inc 4,x ; flag LSB as 0 L8B71 stb 3,x ; save LSB of line number jsr GETCCH ; get input character cmpa #', ; multiple line numbers? (ON GOTO, ON GOSUB) beq L8B13 ; brif so - process another bra L8B17 ; go look for more line numbers L8B7B ldx TXTTAB ; point to start of program leax -1,x ; move back (compensate for inc below) L8B7F leax 1,x ; move forward ldd 2,x ; get this line number std CURLIN ; save it (for error message) jsr L8A86 ; return if end of program leax 3,x ; skip address and line number, stay one before line text L8B8A leax 1,x ; move to next character L8B8C lda ,x ; get input character beq L8B7F ; brif end of line deca ; valid line new line number? beq L8BAE ; brif so suba #2 ; undefined line? bne L8B8A ; brif not pshs x ; save line number pointer ldx #L8BD9-1 ; show UL message jsr STRINOUT ldx ,s ; get input pointer ldd 1,x ; get undefined line number jsr LBDCC ; display line number jsr LBDC5 ; print out "IN XXXX" jsr LB958 ; do a newline puls x ; get input pointer back L8BAE pshs x ; save input pointer ldd 1,x ; get binary value of line number std FPA0+2 ; save it in FPA0 jsr L880E ; adjust FPA0 as integer jsr LBDD9 ; convert to text string puls u ; get previous input pointer address ldb #5 ; each expanded line uses 5 bytes L8BBE leax 1,x ; move pointer forward (in string number) past sign lda ,x ; do we have a digit? beq L8BC9 ; brif not - end of number decb ; mark a byte consumed sta ,u+ ; put digit in program bra L8BBE ; copy another digit L8BC9 leax ,u ; point to address at end of text number tstb ; did number fill whole space? beq L8B8C ; brif so - move on leay ,u ; save end of number pointer leau b,u ; point to the end of the original expanded number jsr L89B8 ; close up gap in program leax ,y ; get end of line number pointer back bra L8B8C ; go process more L8BD9 fcn 'UL ' ; HEX$ function HEXDOL jsr LB740 ; convert argument to positive integer ldx #STRBUF+2 ; point to string buffer ldb #4 ; convert 4 nibbles L8BE5 pshs b ; save nibble counter clrb ; clear digit accumulator lda #4 ; do 4 shifts L8BEA asl FPA0+3 ; shift a bit off the left of the value into low bits of B rol FPA0+2 rolb deca ; done all shifts? bne L8BEA ; brif not tstb ; do we have a nonzero digit? bne L8BFF ; brif so lda ,s ; is it last digit? deca beq L8BFF ; brif so - keep the 0 cmpx #STRBUF+2 ; is it a middle zero? beq L8C0B ; brif not L8BFF addb #'0 ; add ASCII bias cmpb #'9 ; above 9? bls L8C07 ; brif not addb #7 ; adjust into alpha range L8C07 stb ,x+ ; save digit in output clr ,x ; make sure we have a NUL term L8C0B puls b ; get back nibble counter decb ; done all? bne L8BE5 ; brif not leas 2,s ; don't return mainline (we're returning a string) ldx #STRBUF+1 ; point to start of converted number jmp LB518 ; save string in string space, etc., and return it ; DLOAD command DLOAD jsr LA429 ; close files L8C1B clr ,-s ; save default token (not DLOADM) cmpa #'M ; is it DLOADM? bne L8C25 ; brif not sta ,s ; save the "M" jsr GETNCH ; eat the "M" L8C25 jsr LA578 ; parse the file name jsr GETCCH ; get character after file name beq L8C44 ; brif end of line jsr SYNCOMMA ; make sure we have a comma cmpa #', ; do we have 2 commas? beq L8C44 ; brif so - use default baud rate jsr EVALEXPB ; evaluate baud rate L8C36 lda #44*4 ; delay for 300 baud tstb ; was argument 0? beq L8C42 ; brif so - 300 baud lda #44 ; constant for 1200 baud decb ; was it 1? lbne LB44A ; raise error if not L8C42 sta DLBAUD ; save baud rate constant L8C44 jsr L8CD0 ; transmit file name and read in file status pshs a ; save register lda #-3 ; set input to DLOAD sta DEVNUM puls a ; restore register tst ,s+ ; is it DLOADM? bne L8C85 ; brif so jsr LA5C7 ; check for end of line - error if not tstb ; ASCII? beq L8C5F ; brif not - do error jsr LAD19 ; clear out program jmp LAC7C ; go read program L8C5F jmp LA616 ; raise bad file mode ; CLOADM patch for Extended Basic L8C62 jsr GETNCH ; get character after CLOAD cmpa #'M ; CLOADM? lbne CLOAD ; brif not - Color Basic's CLOAD can handle it clr FILSTA ; close tape file jsr GETNCH ; eat the "M" jsr LA578 ; parse file name jsr LA648 ; find the file tst CASBUF+10 ; is it a chunked file? lbeq LA505 ; brif not - Color Basic's CLOADM can handle it ldu CASBUF+8 ; get file type and ASCII flag dec DEVNUM ; set source device to tape jsr LA635 ; go read the first block tfr u,d ; put type and ASCII flag somewhere more useful ; NOTE: DLOADM comes here to do the final processing L8C85 subd #0x200 ; is it binary and "machine language"? bne L8C5F ; brif not - raise an error ldx ZERO ; default load offset jsr GETCCH ; is there any offset? beq L8C96 ; brif not jsr SYNCOMMA ; make sure there's a comma jsr LB73D ; evaluate offset in X L8C96 stx VD3 ; save offset jsr LA5C7 ; raise error if more stuff follows L8C9B bsr L8CC6 ; get type of "amble" pshs a ; save it bsr L8CBF ; read in block length tfr d,y ; save it bsr L8CBF ; read in load address addd VD3 ; add in offset std EXECJP ; save it as the execution address tfr d,x ; put load address in a pointer lda ,s+ ; get "amble" type lbne LA42D ; brif postamble - close file L8CB1 bsr L8CC6 ; read a data byte sta ,x ; save in memory cmpa ,x+ ; did it actually save? bne L8CCD ; brif not RAM - raise error leay -1,y ; done yet? bne L8CB1 ; brif not bra L8C9B ; look for another "amble" L8CBF bsr L8CC1 ; read a character to B L8CC1 bsr L8CC6 ; read character to A exg a,b ; swap character with previously read one L8CC5 rts L8CC6 jsr LA176 ; read a character from input tst CINBFL ; EOF? beq L8CC5 ; brif not L8CCD jmp LA619 ; raise I/O error if EOF L8CD0 bsr L8D14 ; transmit file name pshs b,a ; save file status inca ; was file found? beq L8CDD ; brif not ldu ZERO ; zero U - first block bsr L8CE4 ; read block puls a,b,pc ; restore status and return L8CDD ldb #2*26 ; code for NE error jmp LAC46 ; raise error L8CE2 ldu CBUFAD ; get block number L8CE4 leax 1,u ; bump block number stx CBUFAD ; save new block number ldx #CASBUF ; use cassette buffer jsr L8D7C ; read a block jmp LA644 ; reset input buffer pointers ; Generic input handler for Extended Basic XVEC4 lda DEVNUM ; get device number cmpa #-3 ; DLOAD? bne L8D01 ; brif not leas 2,s ; don't return to mainline code clr CINBFL ; reset EOF flag to not EOF tst CINCTR ; anything available? bne L8D02 ; brif so - fetch one com CINBFL ; flag EOF L8D01 rts L8D02 pshs u,y,x,b ; save registers ldx CINPTR ; get buffer pointer lda ,x+ ; get character from buffer pshs a ; save it for return stx CINPTR ; save new input pointer dec CINCTR ; account for byte removed from buffer bne L8D12 ; brif buffer not empty bsr L8CE2 ; go read a block L8D12 puls a,b,x,y,u,pc ; restore registers, return value, and return L8D14 clra ; clear attempt counter pshs x,b,a ; make a hole for variables leay ,s ; set up frame pointer bra L8D1D ; go read block L8D1B bsr L8D48 ; bump attempt counter L8D1D lda #0x8a ; send file request control code bsr L8D58 bne L8D1B ; brif no echo or error ldx #CFNBUF+1 ; point to file name L8D26 lda ,x+ ; get file name characater jsr L8E04 ; send it cmpx #CFNBUF+9 ; end of file name? bne L8D26 ; brif not bsr L8D62 ; output check byte and look for response bne L8D1B ; transmit name again if not ack bsr L8D72 ; get file type (0xff is not found) bne L8D1B ; brif error sta 2,y ; save file type bsr L8D72 ; read ASCII flag bne L8D1B ; brif error sta 3,y ; save ASCII flag bsr L8D6B ; read check byte bne L8D1B ; brif error leas 2,s ; lose attempt counter and check byte puls a,b,pc ; return file type and ascii flag L8D48 inc ,y ; bump attempt counter lda ,y ; get new count cmpa #5 ; done 5 times? blo L8D6A ; brif not lda #0xbc ; send abort code jsr L8E0C jmp LA619 ; raise an I/O error L8D58 pshs a ; save compare character bsr L8DB8 ; send character bne L8D60 ; brif read error cmpa ,s ; does it match? (set Z if good) L8D60 puls a,pc ; restore character and return L8D62 lda 1,y ; get XOR check byte bsr L8DB8 ; send it and read bne L8D6A ; brif read error cmpa #0xc8 ; is it ack? (set Z if so) L8D6A rts L8D6B bsr L8D72 ; read character from rs232 bne L8D6A ; brif error lda 1,y ; get check byte rts L8D72 bsr L8DBC ; read a character from rs232 pshs a,cc ; save result (and flags) eora 1,y ; accumulate xor checksum sta 1,y puls cc,a,pc ; restore byte, flags, and return L8D7C clra ; reset attempt counter pshs u,y,x,b,a ; make a stack frame asl 7,s ; split block number into two 7 bit chuncks rol 6,s lsr 7,s leay ,s ; set up frame pointer bra L8D8B L8D89 bsr L8D48 ; bump attempt counter L8D8B lda #0x97 ; send block request code bsr L8D58 bne L8D89 ; brif error lda 6,y ; send out block number (high bits first) bsr L8E04 lda 7,y bsr L8E04 bsr L8D62 ; send check byte and get ack bne L8D89 ; brif error bsr L8D72 ; read block size bne L8D89 ; brif read error sta 4,y ; save character count ldx 2,y ; get buffer pointer ldb #128 ; length of data block L8DA7 bsr L8D72 ; read a data byte bne L8D89 ; brif error sta ,x+ ; save byte in buffer decb ; done a whole block? bne L8DA7 ; brif not bsr L8D6B ; read check byte bne L8D89 ; brif error leas 4,s ; lose attempt counter, check byte, and buffer pointer puls a,b,x,pc ; return with character count in A, clean rest of stack L8DB8 clr 1,y ; clear check byte bsr L8E0C ; output character L8DBC clra ; clear attempt counter pshs x,b,cc ; save registers and interrupt status orcc #0x50 ; disable interrupts lda TIMOUT ; get timout delay (variable) ldx ZERO ; get constant timeout value L8DC5 bsr L8DE6 ; get RS232 status bcc L8DC5 ; brif "space" - waiting for "mark" L8DC9 bsr L8DE6 ; get RS232 status bcs L8DC9 ; brif "mark" - waiting for "space" (start bit) bsr L8DF9 ; delay for half of bit time ldb #1 ; set bit probe pshs b ; save it clra ; reset data byte L8DD4 bsr L8DF7 ; wait one bit time ldb PIA1+2 ; get input bit to carry rorb bcc L8DDE ; brif "space" (0) ora ,s ; merge bit probe in L8DDE asl ,s ; shift bit probe over bcc L8DD4 ; brif we haven't done 8 bits leas 1,s ; remove bit probe puls cc,b,x,pc ; restore interrupts, registers, and return L8DE6 ldb PIA1+2 ; get RS232 value rorb ; put in C leax 1,x ; bump timeout bne L8DF6 ; brif nonzero deca ; did the number of waits expire? bne L8DF6 ; brif not leas 2,s ; don't return - we timed out puls cc,b,x ; restore interrupts and registers inca ; clear Z (A was zero above) L8DF6 rts L8DF7 bsr L8DF9 ; do first half of bit delay then fall through for second L8DF9 pshs a ; save register lda DLBAUD ; get baud rate constant L8DFD brn L8DFD ; do nothing - delay deca ; time expired? bne L8DFD ; brif not puls a,pc ; restore register and return L8E04 pshs a ; save character to send eora 1,y ; accumulate chechsum sta 1,y puls a ; get character back L8E0C pshs b,a,cc ; save registers and interrupt status orcc #0x50 ; disable interrupts bsr L8DF7 ; do a bit delay bsr L8DF7 ; do another bit delay clr PIA1 ; set output to space (start bit) bsr L8DF7 ; do a bit delay ldb #1 ; bit probe start at LSB pshs b ; save bitprobe L8E1D lda 2,s ; get output byte anda ,s ; see what our current bit is beq L8E25 ; brif output is 0 lda #2 ; set output to "marking" L8E25 sta PIA1 ; send bit bsr L8DF7 ; do a bit delay asl ,s ; shift bit probe bcc L8E1D ; brif not last bit lda #2 ; set output to marking ("stop" bit) sta PIA1 leas 1,s ; lose bit probe puls cc,a,b,pc ; restore registers, interrupts, and return ; PRINT USING ; This is a massive block of code for something that has limited utility. It is *almost* flexible enough to ; be truly useful outside of a narrow range of use cases. Indeed, this comes in at about 1/8 of the total ; Extended Color Basic ROM. ; ; This uses several variables: ; VD5: pointer to format string descriptor ; VD7: next print item flag ; VD8: right digit counter ; VD9: left digit counter (or length of string argument) ; VDA: status byte (bits as follows): ; 6: force comma ; 5: force leading * ; 4: floating $ ; 3: pre-sign ; 2: post-sign ; 0: scientific notation L8E37 lda #1 ; set length to use to 1 sta VD9 L8E3B decb ; consume character from format string jsr L8FD8 ; show error flag if flags set jsr GETCCH ; get input character lbeq L8ED8 ; brif end of line - bail stb VD3 ; save remaining string length jsr LB156 ; evaluate the argument jsr LB146 ; error if numeric ldx FPA0+2 ; get descriptor for argument stx V4D ; save it for later ldb VD9 ; get length counter to use jsr LB6AD ; get B bytes of string space (do a LEFT$) jsr LB99F ; print the formatted string ldx FPA0+2 ; get formatted string descriptor ldb VD9 ; get requested length subb ,x ; see if we have any left over L8E5F decb ; have we got the right width? lbmi L8FB3 ; brif so - go process more jsr LB9AC ; output a space bra L8E5F ; go see if we're done yet L8E69 stb VD3 ; save current format string counter and pointer stx TEMPTR lda #2 ; initial spaces count = 2 (for the two %s) sta VD9 ; save length counter L8E71 lda ,x ; get character in string cmpa #'% ; is it the end of the sequence? beq L8E3B ; brif so - display requested part of the strign cmpa #0x20 ; space? bne L8E82 ; brif not inc VD9 ; bump spaces count leax 1,x ; move format pointer forward decb ; consume character bne L8E71 ; brif not end of format string L8E82 ldx TEMPTR ; restore format string pointer ldb VD3 ; get back format string length lda #'% ; show % as debugging aid L8E88 jsr L8FD8 ; send error indicator if flags set jsr PUTCHR ; output character bra L8EB9 ; go process more format string ; PRINT extension for USING XVEC9 cmpa #0xcd ; USING? beq L8E95 ; brif so rts ; return to mainline code ; This is the main entry point for PRINT USING L8E95 leas 2,s ; don't return to the mainline code jsr LB158 ; evaluate the format string jsr LB146 ; error if numeric ldb #'; ; make sure there's a ; after the string jsr LB26F ldx FPA0+2 ; get format string descriptor stx VD5 ; save it for later bra L8EAE ; process format string L8EA8 lda VD7 ; is there a print item? beq L8EB4 ; brif not ldx VD5 ; get back format string descriptor L8EAE clr VD7 ; reset next print item flag ldb ,x ; get length of format string bne L8EB7 ; brif string is non-null L8EB4 jmp LB44A ; raise FC error L8EB7 ldx 2,x ; point to start of string L8EB9 clr VDA ; clear status (new item) L8EBB clr VD9 ; clear left digit counter lda ,x+ ; get character from format string cmpa #'! ; ! (use first character of string)? lbeq L8E37 ; brif so cmpa #'# ; digit? beq L8F24 ; brif so - handle numeric decb ; consume format character bne L8EE2 ; brif not done jsr L8FD8 ; show a "+" if any flags set - indicates error at end of string jsr PUTCHR ; output format string character L8ED2 jsr GETCCH ; get current input character bne L8EA8 ; brif not end of statement lda VD7 ; get next item flag L8ED8 bne L8EDD ; brif more print items jsr LB958 ; do newline L8EDD ldx VD5 ; point to format string descriptor jmp LB659 ; remove from string stack, etc., if appropriate (and return) L8EE2 cmpa #'+ ; is it + (pre-sign)? bne L8EEF ; brif not jsr L8FD8 ; send a "+" if flags set lda #8 ; flag for pre-sign sta VDA ; set flags bra L8EBB ; go interpret some more stuff L8EEF cmpa #'. ; decimal? beq L8F41 ; brif so - numeric cmpa #'% ; % (show string)? lbeq L8E69 ; brif so cmpa ,x ; do we have two identical characters? L8EFB bne L8E88 ; brif not - invalid format character cmpa #'$ ; double $? beq L8F1A ; brif so - floating $ cmpa #'* ; double *? bne L8EFB ; brif not lda VDA ; get status byte ora #0x20 ; enable * padding sta VDA cmpb #2 ; is $$ the last two? blo L8F20 ; brif so lda 1,x ; is it $ after? cmpa #'$ bne L8F20 ; brif not decb ; consume the "$" leax 1,x inc VD9 ; add to digit counter * pad + $ counter L8F1A lda VDA ; indicate floating $ ora #0x10 sta VDA L8F20 leax 1,x ; consume the second format character inc VD9 ; add one more left place L8F24 clr VD8 ; clear right digit counter L8F26 inc VD9 ; bump left digit counter decb ; consume character beq L8F74 ; brif end of string lda ,x+ ; get next format character cmpa #'. ; decimal? beq L8F4F ; brif so cmpa #'# ; digit? beq L8F26 ; brif so cmpa #', ; comma flag? bne L8F5A ; brif not lda VDA ; set commas flag ora #0x40 sta VDA bra L8F26 ; handle more characters to left of decimal L8F41 lda ,x ; get character after . cmpa #'# ; digit? lbne L8E88 ; brif not - invalid lda #1 ; set right digit counter to 1 (for the .) sta VD8 leax 1,x ; consume the . L8F4F inc VD8 ; add one to right digit counter decb ; consume character beq L8F74 ; brif end of format string lda ,x+ ; get another format character cmpa #'# ; digit? beq L8F4F ; brif so L8F5A cmpa #0x5e ; up arrow? bne L8F74 ; brif not cmpa ,x ; two of them? bne L8F74 ; brif not cmpa 1,x ; three of them? bne L8F74 ; brif not cmpa 2,x ; four of them? bne L8F74 ; brif not cmpb #4 ; string actually has the characters? blo L8F74 ; brif not subb #4 ; consome them leax 4,x inc VDA ; set scientific notation bit L8F74 leax -1,x ; back up input pointer inc VD9 ; add one digit for pre-sign force lda VDA ; is it pre-sign? bita #8 bne L8F96 ; brif so dec VD9 ; undo pre-sign adjustment tstb ; end of string? beq L8F96 ; brif so lda ,x ; get next character suba #'- ; post sign force? beq L8F8F ; brif so cmpa #'+-'- ; plus? bne L8F96 ; brif not lda #8 ; trailing + is a pre-sign force L8F8F ora #4 ; add in post sign flag ora VDA ; merge with flags sta VDA decb ; consume character L8F96 jsr GETCCH ; do we have an argument lbeq L8ED8 ; brif not stb VD3 ; save format string length jsr LB141 ; evluate numeric expression lda VD9 ; get left digit counter adda VD8 ; add in right digit counter cmpa #17 ; is it more than 16 digits + decimal? lbhi LB44A ; brif so - this is a problem jsr L8FE5 ; format value according to settings leax -1,x ; move buffer pointer back jsr STRINOUT ; display formatted number string L8FB3 clr VD7 ; reset next print item flag jsr GETCCH ; get current input character beq L8FC6 ; brif end of statement sta VD7 ; set next print flag to nonzero cmpa #'; ; list separator ;? beq L8FC4 ; brif so jsr SYNCOMMA ; require a comma between if not ; bra L8FC6 ; process next item L8FC4 jsr GETNCH ; munch the semicolon L8FC6 ldx VD5 ; get format string descriptor ldb ,x ; get length of string subb VD3 ; subtract amount left after last item ldx 2,x ; point to string address abx ; move pointer to correct spot ldb VD3 ; get remaining string length lbne L8EB9 ; if we have more, interpret from there jmp L8ED2 ; re-interpret from start if we hit the end L8FD8 pshs a ; save character lda #'+ ; "error" flag character tst VDA ; did we have some flags set? beq L8FE3 ; brif not jsr PUTCHR ; output error flag L8FE3 puls a,pc ; restore character and return L8FE5 ldu #STRBUF+4 ; point to string buffer ldb #0x20 ; blank space lda VDA ; get flags bita #8 ; pre-sign? beq L8FF2 ; brif not ldb #'+ ; plus sign L8FF2 tst FP0SGN ; get sign of value bpl L8FFA ; brif positive clr FP0SGN ; make number positive (for later) ldb #'- ; negative sign L8FFA stb ,u+ ; put sign in buffer ldb #'0 ; put a zero there stb ,u+ anda #1 ; check scientific notation force lbne L910D ; brif so ldx #LBDC0 ; point to FP 1E+9 jsr LBCA0 ; is it less? bmi L9023 ; brif so jsr LBDD9 ; convert FP number to string (we're doing scientific notation) L9011 lda ,x+ ; advance pointer to end of string bne L9011 L9015 lda ,-x ; make a hole at the start sta 1,x cmpx #STRBUF+3 ; done yet? bne L9015 ; brif not lda #'% ; put "overflow" flag at start sta ,x rts L9023 lda FP0EXP ; get exponent of value sta V47 ; save it beq L902C ; brif value is 0 jsr L91CD ; convert to number with 9 significant figures to left of decimal L902C lda V47 ; get base 10 exponent offset lbmi L90B3 ; brif < 100,000,000 nega ; get negative difference adda VD9 ; add to number of left digits suba #9 ; account for the 9 we actually have jsr L90EA ; put leading zeroes in buffer jsr L9263 ; initialize the decimal point and comma counters jsr L9202 ; convert FPA0 to decimal ASCII in buffer lda V47 ; get base 10 exponent jsr L9281 ; put that many zeroes in buffer, stop at decimal point lda V47 ; get base 10 exponent jsr L9249 ; check for decimal lda VD8 ; get right digit counter bne L9050 ; brif we want stuff after decimal leau -1,u ; delete decimal if not needed L9050 deca ; subtract one place (for decimal) jsr L90EA ; put zeroes in buffer (trailing) L9054 jsr L9185 ; insert * padding, floating $, and post-sign tsta ; was there a post sign? beq L9060 ; brif not cmpb #'* ; was first character a *? beq L9060 ; brif so stb ,u+ ; store the post sign L9060 clr ,u ; make srue it's NUL terminated ldx #STRBUF+3 ; point to start of buffer L9065 leax 1,x ; move to next character stx TEMPTR ; save it for later lda VARPTR+1 ; get address of decimal point suba TEMPTR+1 ; subtract out actual digits left of decimal suba VD9 ; subtract out required left digits beq L90A9 ; brif no padding needed lda ,x ; get current character cmpa #0x20 ; space? beq L9065 ; brif so - advance pointer cmpa #'* ; *? beq L9065 ; brif so - advance pointer clra ; zero on stack is end of data ponter L907C pshs a ; save character on stack lda ,x+ ; get next character cmpa #'- ; minus? beq L907C ; brif so cmpa #'+ ; plus? beq L907C ; brif so cmpa #'$ ; $? beq L907C ; brif so cmpa #'0 ; zero? bne L909E ; brif not lda 1,x ; get character after 0 bsr L90AA ; clear carry if number bcs L909E ; brif not number L9096 puls a ; get character off stack sta ,-x ; put it back in string buffer bne L9096 ; brif not - restore another bra L9065 ; keep cleaning up buffer L909E puls a ; get the character on the stack tsta ; is it NUL? bne L909E ; brif not ldx TEMPTR ; get string buffer start pointer lda #'% ; put error flag in front sta ,-x L90A9 rts L90AA cmpa #'0 ; zero? blo L90B2 ; brif not suba #'9+1 ; set C if > "9" suba #-('9+1) L90B2 rts L90B3 lda VD8 ; get right digit counter beq L90B8 ; brif not right digits deca ; account for decimal point L90B8 adda V47 ; add base 10 exponent offset bmi L90BD ; if >= 0, no shifts are required clra ; force shift counter to 0 L90BD pshs a ; save shift counter L90BF bpl L90CB ; brif positive count pshs a ; save shift counter jsr LBB82 ; divide FPA0 by 10 (shift 1 digit to the right) puls a ; get shift counter back inca ; account for the shift bra L90BF ; see if we're done yet L90CB lda V47 ; get base 10 exponent offset suba ,s+ ; account for adjustment sta V47 ; save new exponent offset adda #9 ; account for significant places bmi L90EE ; brif we don't need zeroes to left lda VD9 ; get left decimal counter suba #9 ; account for significant figures suba V47 ; subtract exponent offset bsr L90EA ; output leading zeroes jsr L9263 ; initialize decimal and comma counters bra L90FF ; process remainder of digits L90E2 pshs a ; save zero counter lda #'0 ; insert a 0 sta ,u+ puls a ; get back counter L90EA deca ; do we need more zeroes? bpl L90E2 ; brif so rts L90EE lda VD9 ; get left digit counter bsr L90EA ; put that many zeroes in jsr L924D ; put decimal in buffer lda #-9 ; figure out filler zeroes suba V47 bsr L90EA ; output required leader zeroes clr V45 ; clear decimal pointer counter clr VD7 ; clear comma counter L90FF jsr L9202 ; decode FPA0 to decimal string lda VD8 ; get right digit counter bne L9108 ; brif there are right digits ldu VARPTR ; point to decimal location of decimal L9108 adda V47 ; add base 10 exponent lbra L9050 ; add in leading astrisks, etc. L910D lda FP0EXP ; get exponent of FPA0 pshs a ; save it beq L9116 ; brif 0 jsr L91CD ; convert to number with 9 figures L9116 lda VD8 ; get right digit counter beq L911B ; brif no right digits deca ; account for decimal point L911B adda VD9 ; get left digit counter clr STRBUF+3 ; use buffer byte as temporary storage ldb VDA ; get status flags andb #4 ; post-sign? bne L9129 ; brif so com STRBUF+3 ; flip byte if no post sign L9129 adda STRBUF+3 ; subtract 1 if no post sign suba #9 ; account for significant figures pshs a ; save shift counter L9130 bpl L913C ; brif no more shifts needed pshs a ; save counter jsr LBB82 ; divide by 10 (shift right one) puls a ; get back counter inca ; account for the shift bra L9130 ; see if we need more L913C lda ,s ; get original shift count bmi L9141 ; brif shifting happened clra ; flag for no shifting L9141 nega ; calculate position of decimal (negate shift count, add left digit and post sign if needed) adda VD9 ; add left digit counter inca ; and post sign adda STRBUF+3 sta V45 ; save decimal counter clr VD7 ; clear comma counter jsr L9202 ; convert to decimal string puls a ; get shift counter jsr L9281 ; put the needed zeroes in lda VD8 ; get right digit counter bne L915A ; brif we want some leau -1,u ; remove te decimal point L915A ldb ,s+ ; get original exponent beq L9167 ; brif it was 0 ldb V47 ; get base 10 exponent addb #9 ; account for significant figures subb VD9 ; remove left digit count subb STRBUF+3 ; add one if post sign L9167 lda #'+ ; positive sign tstb ; is base 10 exponent positive? bpl L916F ; brif so lda #'- ; negative sign negb ; flip exponent L916F sta 1,u ; put exponent sign lda #'E ; put "E" and advance output pointer sta ,u++ lda #'0-1 ; initialize digit accumulator L9177 inca ; bump digit subb #12 ; are we at the right digit? bcc L9177 ; brif not addb #'0+12 ; add ASCII bias and undo extra subtraction std ,u++ ; save exponent in buffer clr ,u ; clear final byte in buffer jmp L9054 ; insert *, $, etc. L9185 ldx #STRBUF+4 ; point to start of result ldb ,x ; get sign pshs b ; save it lda #0x20 ; default pad with spaces ldb VDA ; get flags bitb #0x20 ; padding with *? puls b beq L919E ; brif no padding lda #'* ; pad with * cmpb #0x20 ; do we have a blank? (positive) bne L919E ; brif not tfr a,b ; use pad character L919E pshs b ; save first character L91A0 sta ,x+ ; store padding ldb ,x ; get next character beq L91B6 ; brif end of string cmpb #'E ; exponent? beq L91B6 ; brif so - treat as 0 cmpb #'0 ; zero? beq L91A0 ; brif so - pad it cmpb #', ; leading comma? beq L91A0 ; brif so - pad it cmpb #'. ; decimal? bne L91BA ; brif so - don't put a 0 before it L91B6 lda #'0 ; put a zero before sta ,-x L91BA lda VDA ; get status byte bita #0x10 ; floating $? beq L91C4 ; brif not ldb #'$ ; stuff a $ in stb ,-x L91C4 anda #4 ; pre-sgn? puls b ; get back first character bne L91CC ; brif not stb ,-x ; save leading character (sign) L91CC rts L91CD pshs u ; save buffer pointer clra ; initial exponent offset is 0 L91D0 sta V47 ; save exponent offset ldb FP0EXP ; get actual exponent cmpb #0x80 ; is value >= 1.0? bhi L91E9 ; brif so ldx #LBDC0 ; point to FP number 1E9 jsr LBACA ; multiply by 1000000000 lda V47 ; account for 9 shifts suba #9 bra L91D0 ; brif not there yet L91E4 jsr LBB82 ; divide by 10 inc V47 ; account for shift L91E9 ldx #LBDBB ; point to 999999999 jsr LBCA0 ; compare it bgt L91E4 ; brif not in range yet L91F1 ldx #LBDB6 ; point to 99999999.9 jsr LBCA0 ; compare bgt L9200 ; brif in range jsr LBB6A ; multiply by 10 dec V47 ; account for shift bra L91F1 ; see if we're in range yet L9200 puls u,pc ; restore buffer pointer and return L9202 pshs u ; save buffer pointer jsr LB9B4 ; add .5 (round off) jsr LBCC8 ; convert to integer format puls u ; restore buffer pointer ldx #LBEC5 ; point to 32 bit powers of 10 (alternating signs) ldb #0x80 ; intitial digit counter is 0 with 0x80 bias L9211 bsr L9249 ; check for comma L9213 lda FPA0+3 ; add a power of 10 adda 3,x sta FPA0+3 lda FPA0+2 adca 2,x sta FPA0+2 lda FPA0+1 adca 1,x sta FPA0+1 lda FPA0 adca ,x sta FPA0 incb ; add one to digit counter rorb ; set V if carry and sign differ rolb bvc L9213 ; brif we haven't "wrapped" bcc L9235 ; brif subtracting subb #10+1 ; take 9's complement if adding negb L9235 addb #'0-1 ; add in ASCII bias leax 4,x ; move to next power tfr b,a ; save digit anda #0x7f ; mask off subtract flag sta ,u+ ; save digit comb ; toggle add/subtract andb #0x80 cmpx #LBEE9 ; done all places? bne L9211 ; brif not clr ,u ; but NUL at end L9249 dec V45 ; at decimal? bne L9256 ; brif not L924D stu VARPTR ; save decimal point pointer lda #'. ; insert decimal sta ,u+ clr VD7 ; clear comma counter rts L9256 dec VD7 ; do we need a comma? bne L9262 ; brif not lda #3 ; reset comma counter sta VD7 lda #', ; insert comma sta ,u+ L9262 rts L9263 lda V47 ; get base 10 exponent offset adda #10 ; account for significant figures sta V45 ; save decimal counter inca ; add one for decimal point L926A suba #3 ; divide by 3, leave remainder in A bcc L926A adda #5 ; renormalize to range 1-3 sta VD7 ; save comma counter lda VDA ; get status anda #0x40 ; commas wanted? bne L927A ; brif not sta VD7 ; clear comma counter L927A rts L927B pshs a ; save zeroes counter bsr L9249 ; check for decimal puls a ; get back counter L9281 deca ; need a zero? bmi L928E ; brif not pshs a ; save counter lda #'0 ; put a zero sta ,u+ lda ,s+ ; get back counter and set flags bne L927B ; brif not done enough L928E rts ; From here to the end of the Extended Basic ROM is the PMODE graphics system and related ; infrastructure with the exception of the PLAY command which shares some of its machinery ; with the DRAW command. ; ; Fetch screen address calculation routine address for the selected graphics mode L928F ldu #L929C ; point to normalization routine jump table lda PMODE ; get graphics mode asla ; two bytes per address ldu a,u ; get routine address rts ; Normalize VERBEG/HORBEG coordinates and return screen address in X and pixel mask in A. L9298 bsr L928F ; fetch normalization routine pointer jmp ,u ; transfer control to it L929C fdb L92A6 ; PMODE 0 fdb L92C2 ; PMODE 1 fdb L92A6 ; PMODE 2 fdb L92C2 ; PMODE 3 fdb L92A6 ; PMODE 4 ; Two colour mode address calculatoin L92A6 pshs u,b ; savce registers ldb HORBYT ; get number of bytes in each graphics row lda VERBEG+1 ; get vertical coordinate mul addd BEGGRP ; now D is the absolute address of the start of the row tfr d,x ; get address to the return location ldb HORBEG+1 ; get horizontal coordinate lsrb ; divide by 8 (8 pixels per byte in 2 colour mode) lsrb lsrb abx ; now X is the address of the actual pixel byte lda HORBEG+1 ; get horizontal coordinate anda #7 ; keep only the low 3 bits which contain the pixel number ldu #L92DD ; point to pixel mask lookup lda a,u ; get pixel mask puls b,u,pc ; restore registers and return result ; four colour address calculation L92C2 pshs u,b ; save registers ldb HORBYT ; get bytes per graphics row lda VERBEG+1 ; get vertical coordinate mul addd BEGGRP ; now D is the address of the start of the row tfr d,x ; put it in returnlocatin ldb HORBEG+1 ; get horizontal coordinate lsrb ; divide by 4 (four colour modes have four pixels per byte) lsrb abx ; now X points to the screen byte lda HORBEG+1 ; get horizontal coordinate anda #3 ; keep low two bits for pixel number ldu #L92E5 ; point to four colour pixel masks lda a,u ; get pixel mask puls b,u,pc ; restore registers and return result L92DD fcb 0x80,0x40,0x20,0x10 ; two colour pixel masks fcb 0x08,0x04,0x02,0x01 L92E5 fcb 0xc0,0x30,0x0c,0x03 ; four colour pixel masks ; Move X down one graphics row L92E9 ldb HORBYT ; get bytes per row abx ; add to screen address rts ; Move one pixel right in 2 colour mode L92ED lsra ; move pixel mask right bcc L92F3 ; brif same byte rora ; move pixel mask to left of byte leax 1,x ; move to next byte L92F3 rts ; Move one pixel right in 4 colour mode L92F4 lsra ; shift mask half a pixel right bcc L92ED ; brif not past end of byte - shift one more lda #0xc0 ; set mask on left of byte leax 1,x ; move to next byte rts ; Evaluate two expressions (coordinates). Put first in HORBEG and second in VERBEG. L92FC jsr LB734 ; evaluate two expressions - first in BINVAL, second in B ldy #HORBEG ; point to storage location L9303 cmpb #192 ; is vertical outside range? blo L9309 ; brif not ldb #191 ; max it at bottom of screen L9309 clra ; zero extend vertical coordinate std 2,y ; save vertical coordinate ldd BINVAL ; get horizontal coordinate cmpd #256 ; in range? blo L9317 ; brif so ldd #255 ; max it out to right side of screen L9317 std ,y ; save horizontal coordinate rts ; Normalize coordinates for proper PMODE L931A jsr L92FC ; parse coordinates L931D ldu #HORBEG ; point to start coordinates L9320 lda PMODE ; get graphics mode cmpa #2 ; is it pmode 0 or 1? bhs L932C ; brif not ldd 2,u ; get vertical coordinate lsra ; divide it by two rorb std 2,u ; save it back L932C lda PMODE ; get graphics mode cmpa #4 ; pmode 4? bhs L9338 ; brif so ldd ,u ; cut horizontal coordinate in half lsra rorb std ,u ; save new coordinate L9338 rts ; PPOINT function PPOINT jsr L93B2 ; evaluate two expressions (coordinates) jsr L931D ; normalize coordinates jsr L9298 ; get screen address anda ,x ; get colour value of desired screen coordinate ldb PMODE ; get graphics mode rorb ; is it a two colour m ode? bcc L935B ; brif so L9349 cmpa #4 ; is it on rightmost bits? blo L9351 ; brif not rora ; shift right rora bra L9349 ; see if we're there yet L9351 inca ; colour numbers start at 1 asla ; add in colour set (0 or 8) adda CSSVAL lsra ; get colour in range of 0 to 8 L9356 tfr a,b ; put result to B jmp LB4F3 ; return B as FP number L935B tsta ; is pixel on? beq L9356 ; brif not, return 0 (off) clra ; set colour number to "1" bra L9351 ; make it 1 or 5 and return ; PSET command PSET lda #1 ; PSET flag bra L9366 ; go turn on the pixel ; PRESET command PRESET clra ; PRESET flag L9366 sta SETFLG ; store whether we're setting or resetting jsr LB26A ; enforce ( jsr L931A ; evaluate coordinates jsr L9581 ; evaluate colour jsr LB267 ; enforce ) jsr L9298 ; get address of pixel L9377 ldb ,x ; get screen data pshs b ; save it tfr a,b ; duplicate pixel mask coma ; invert mask anda ,x ; turn off screen pixel andb ALLCOL ; adjust pixel mask to be the current colour pshs b ; merge pixel data into the screen data ora ,s+ sta ,x ; put it on screen suba ,s+ ; nonzero if screen data changed ora CHGFLG ; propagate change flag sta CHGFLG rts ; Evaluate two sets of coordinates separated by a minus sign. First at HORBEG,VERBEG and ; second at HOREND,VEREND. If no first set, use HORDEF,VERDEF. L938F ldx HORDEF ; set default start coords stx HORBEG ldx VERDEF stx VERBEG cmpa #0xac ; do we start with a -? beq L939E ; brif no starting coordinates jsr L93B2 ; parse coordinates L939E ldb #0xac ; make sure we have a - jsr LB26F jsr LB26A ; require a ( jsr LB734 ; evaluate two expressions ldy #HOREND ; point to storage location jsr L9303 ; process coordinates bra L93B8 ; finish up with a ) L93B2 jsr LB26A ; make sure there's a ( jsr L92FC ; evaluate coordinates L93B8 jmp LB267 ; force a ) ; LINE command LINE cmpa #0x89 ; is it LINE INPUT? lbeq L89C0 ; brif so - go handle it cmpa #'( ; starting coord? beq L93CE ; brif so cmpa #0xac ; leading -? beq L93CE ; brif so ldb #'@ ; if it isn't the above, make sure it's @ jsr LB26F L93CE jsr L938F ; parse coordinates ldx HOREND ; set ending coordinates as the defaults stx HORDEF ldx VEREND stx VERDEF jsr SYNCOMMA ; make sure we have a comma cmpa #0xbe ; PRESET? beq L93E9 ; brif so cmpa #0xbd ; PSET? lbne LB277 ; brif not ldb #01 ; PSET flag skip1lda ; skip byte and set A nonzero L93E9 clrb ; PRESET flag pshs b ; save PSET/PRESET flag jsr GETNCH ; eat the PSET/PRESET jsr L9420 ; normalize coordinates puls b ; get back PSET/PRESET flag stb SETFLG ; flag which we're doing jsr L959A ; set colour byte jsr GETCCH ; get next bit lbeq L94A1 ; brif no box option jsr SYNCOMMA ; make sure it's comma ldb #'B ; make sure "B" for "box" jsr LB26F bne L9429 ; brif something follows the B bsr L9444 ; draw horizontal line bsr L946E ; draw vertical line ldx HORBEG ; save horizontal coordinate pshs x ; save it ldx HOREND ; switch in horizontal end stx HORBEG bsr L946E ; draw vertical line puls x ; get back original start stx HORBEG ; put it back ldx VEREND ; do the same dance with the vertical end stx VERBEG bra L9444 ; draw horizontal line L9420 jsr L931D ; normalize the start coordinates ldu #HOREND ; point to end coords jmp L9320 ; normalize those coordinates L9429 ldb #'F ; make sure we have "BF" for "filled box" jsr LB26F bra L9434 ; fill the box L9430 leax -1,x ; move vertical coordinate up one L9432 stx VERBEG ; save new vertical coordinate L9434 jsr L9444 ; draw a horizontal line ldx VERBEG ; are we at the end of the box? cmpx VEREND beq L9443 ; brif so bcc L9430 ; brif we're moving up the screen leax 1,x ; move down the screen bra L9432 ; go draw another line L9443 rts ; Draw a horizontal line from HORBEG to HOREND at VERBEG using color mask in ALLCOL L9444 ldx HORBEG ; get starting horizontal coordinate pshs x ; save it jsr L971D ; get absolute value of HOREND-HORBEG bcc L9451 ; brif end is > start ldx HOREND ; copy end coordinate to start it is smaller stx HORBEG L9451 tfr d,y ; save difference - it's a pixel count leay 1,y ; coordinates are inclusive jsr L9298 ; get screen position of start coord puls u ; restore original start coordinate stu HORBEG bsr L9494 ; point to routine to move pizel pointers to right L945E sta VD7 ; save pixel mask jsr L9377 ; turn on pixel lda VD7 ; get pixel mask back jsr ,u ; move one pixel right leay -1,y ; turned on enough pixels yet? bne L945E ; brif not L946B rts L946C puls b,a ; clean up stack L946E ldd VERBEG ; save original vertical start coordinate pshs b,a jsr L9710 ; get vertical difference bcc L947B ; brif end coordinate > start ldx VEREND ; swap in end coordinate if not stx VERBEG L947B tfr d,y ; save number of pixels to set leay 1,y ; the coordinates are inclusive jsr L9298 ; get screen pointer puls u ; restore start coordinate stu VERBEG bsr L949D ; point to routine to move down one row bra L945E ; draw vertical line ; Point to routine which will move one pixel right L948A fdb L92ED ; PMODE 0 fdb L92F4 ; PMODE 1 fdb L92ED ; PMODE 2 fdb L92F4 ; PMODE 3 fdb L92ED ; PMODE 4 L9494 ldu #L948A ; point to jump table ldb PMODE ; get graphics mode aslb ; two bytes per address ldu b,u ; get jump address rts ; Point to routine to move down one row L949D ldu #L92E9 ; point to "move down one row" routien rts ; Draw a line from HORBEG,VERBEG to HOREND,VEREND L94A1 ldy #L950D ; point to increase vertical coord jsr L9710 ; calculate difference lbeq L9444 ; brif none - draw a horizontal line bcc L94B2 ; brif vertical end is > vertical start ldy #L951B ; point to decrease vertical coord L94B2 pshs d ; save vertical difference ldu #L9506 ; point to increase horizontal coord jsr L971D ; get difference beq L946C ; brif none - draw a vertical line bcc L94C1 ; brif horizontal end > horizontal start ldu #L9514 ; point to decrease hoizontal coord L94C1 cmpd ,s ; compare vert and horiz differences puls x ; get X difference bcc L94CC ; brif horiz diff > vert diff exg u,y ; swap change routine pointers exg d,x ; swap differences L94CC pshs u,d ; save larger difference and routine pshs d ; save larger difference lsra ; divide by two rorb bcs L94DD ; brif odd number cmpu #L950D+1 ; increase or decrease? blo L94DD ; brif increase subd #1 ; back up one L94DD pshs x,b,a ; save smallest difference and initial middle offset jsr L928F ; point to proper coordinate to screen conversion routine L94E2 jsr ,u ; convert coordinates to screen address jsr L9377 ; turn on a pixel ldx 6,s ; get distnace counter beq L9502 ; brif line is completely drawn leax -1,x ; account for one pixel drawn stx 6,s ; save new counter jsr [8,s] ; increment/decrement larger delta ldd ,s ; get the minor coordinate increment counter addd 2,s ; add the smallest difference std ,s ; save new minor coordinate incrementcounter subd 4,s ; subtractout the largest difference bcs L94E2 ; brif not greater - draw another pixel std ,s ; save new minor coordinate increment jsr ,y ; adjust minor coordinate bra L94E2 ; go draw another pixel L9502 puls x ; clean up stack and return puls a,b,x,y,u,pc L9506 ldx HORBEG ; bump horizontal coordinate leax 1,x stx HORBEG rts L950D ldx VERBEG ; bump vertical coordinate leax 1,x stx VERBEG rts L9514 ldx HORBEG ; decrement horizontal coordinate leax -1,x stx HORBEG rts L951B ldx VERBEG ; decrement vertical coordinate leax -1,x stx VERBEG rts ; Get normalized maximum coordinate values in VD3 and VD5 L9522 ldu #VD3 ; point to temp storage ldx #255 ; set maximum horizontal stx ,u ldx #191 ; set maximum vertical stx 2,u jmp L9320 ; normalize them ; PCLS command PCLS beq L9542 ; clear to background colour if no argument bsr L955A ; evaluate colour L9536 lda #0x55 ; consider each byte as 4 groups of 2 bit sub-nibbles mul ; now colour is in all four sub-pixels ldx BEGGRP ; get start of graphics screen L953B stb ,x+ ; set byte to proper colour cmpx ENDGRP ; at end of graphics page? bne L953B ; brif not rts L9542 ldb BAKCOL ; get background colour bra L9536 ; do the clearing dance ; COLOR command COLOR cmpa #', ; check for comma beq L9552 ; brif no foreground colour bsr L955A ; evaluate first colour stb FORCOL ; set foreground colour jsr GETCCH ; is there a background colour? beq L9559 ; brif not L9552 jsr SYNCOMMA ; make sure we have a comma bsr L955A ; evaluate background colour argument stb BAKCOL ; set background colour L9559 rts ; Evaluate a colour agument and convert to proper code based on graphics mode L955A jsr EVALEXPB ; evaluate colour code L955D cmpb #9 ; is it in range of 0-8? lbhs LB44A ; brif not - raise error clra ; CSS value for first colour set cmpb #5 ; is it first or second colour set? blo L956C ; brif first colour set lda #8 ; flag second colour set subb #4 ; adjust into basic range L956C pshs a ; save CSS value lda PMODE ; get graphics mode rora ; 4 colour or 2? bcc L957B ; brif 2 colour tstb ; was it 0? bne L9578 ; brif not L9576 ldb #4 ; if so, make it 4 L9578 decb ; convert to zero based L9579 puls a,pc ; get back CSS value and return L957B rorb ; is colour number odd? bcs L9576 ; brif so - force all bits set colour clrb ; force colour 0 if not bra L9579 ; Set all pixel byte and active colour L9581 jsr L959A ; set colour byte jsr GETCCH ; is there something to evaluate? beq L9598 ; brif not cmpa #') ; )? beq L9598 ; brif so jsr SYNCOMMA ; force comma cmpa #', ; another comma? beq L9598 ; brif so jsr L955A ; evaluate expression and return colour bsr L95A2 ; save colour and pixel byte L9598 jmp GETCCH ; re-fetch input character and return L959A ldb FORCOL ; use foreground colour by default tst SETFLG ; doing PRESET? bne L95A2 ; brif not ldb BAKCOL ; default to background colour L95A2 stb WCOLOR ; save working colour lda #0x55 ; consider a byte as 4 pixels mul ; now all pixels are set to the same bit pattern stb ALLCOL ; set all pixels byte rts L95AA bne L95CF ; brif graphics mode L95AC pshs x,b,a ; save registers ldx #SAMREG+8 ; point to middle of control register sta 10,x ; reset display page to 0x400 sta 8,x sta 6,x sta 4,x sta 2,x sta 1,x sta -2,x sta -4,x ; reset to alpha mode sta -6,x sta -8,x lda PIA1+2 ; set VDG to alpha mode, colour set 0 anda #7 sta PIA1+2 puls a,b,x,pc ;restore registers and return L95CF pshs x,b,a ; save registers lda PMODE ; get graphics mode adda #3 ; offset to 3-7 (we don't use the bottom 3 modes) ldb #0x10 ; shift to high 4 bits mul orb #0x80 ; set to graphics mode orb CSSVAL ; set the desired colour set lda PIA1+2 ; get get original PIA values anda #7 ; mask off VDG control pshs a ; merge with new VDG control orb ,s+ stb PIA1+2 ; set new VDG mode lda BEGGRP ; get start of graphics page lsra ; divide by two - pages are on 512 byte boundaries jsr L960F ; set SAM control register lda PMODE ; get graphics mode adda #3 ; shift to VDG values cmpa #7 ; PMODE 4? bne L95F7 ; brif not deca ; treat PMODE 4 the same as PMODE 3 L95F7 bsr L95FB ; program SAM's VDG bits puls a,b,x,pc ; restore registers and return L95FB ldb #3 ; set 3 bits in register ldx #SAMREG ; point to VDG control bits L9600 rora ; get bit to set bcc L9607 ; brif we need to clear the bit sta 1,x ; set the bit bra L9609 L9607 sta ,x ; clear the bit L9609 leax 2,x ; move to next bit decb ; done all bits? bne L9600 ; brif not rts L960F ldb #7 ; 7 screen address bits ldx #SAMREG+6 ; point to screen address bits in SAM bra L9600 ; go program SAM bits L9616 lda PIA1+2 ; get VDG bits anda #0xf7 ; keep everything but CSS bit ora CSSVAL ; set correct CSS bit sta PIA1+2 ; set desired CSS rts ; PMODE command PMODETOK cmpa #', ; is first argument missing? beq L9650 ; brif so jsr EVALEXPB ; evaluate PMODE number cmpb #5 ; valid (0-4)? bhs L966D ; brif not lda #6 ; get start of graphics memory L962E sta BEGGRP ; set start of graphics page aslb ; multiply mode by two (table has two bytes per entry) ldu #L9706+1 ; point to lookup table adda b,u ; add in number of 256 byte pages used for graphics screen cmpa TXTTAB ; does it fit? bhi L966D ; brif not sta ENDGRP ; save end of graphics leau -1,u ; point to bytes per horizontal row lda b,u ; get bytes per row sta HORBYT ; set it lsrb ; restore PMODE value stb PMODE ; set graphics mode clra ; set background colour to 0 sta BAKCOL lda #3 ; set foreground colour to maximum (3) sta FORCOL jsr GETCCH ; is there a starting page number? beq L966C ; brif not L9650 jsr LB738 ; evaluate an expression following a comma tstb ; page 0? beq L966D ; brif so - not valid decb ; zero-base it lda #6 ; each graphics page is 6*256 mul addb GRPRAM ; add to start of graphics memory pshs b ; save start of screen memory addb ENDGRP ; add current and address subb BEGGRP ; subtract current start (adds size of screen) cmpb TXTTAB ; does it fit? bhi L966D ; brif not stb ENDGRP ; save new end of graphics puls b ; get back start of graphics stb BEGGRP ; set start of graphics L966C rts L966D jmp LB44A ; raise FC error ; SCREEN command SCREEN cmpa #', ; is there a mode? beq L967F ; brif no mode jsr EVALEXPB ; get mode argument tstb ; set Z if alpha jsr L95AA ; set SAM/VDG for graphics mode jsr GETCCH ; is there a second argument? beq L966C ; brif not L967F jsr LB738 ; evaluate ,<expr> tstb ; colour set 0? beq L9687 ; brif so ldb #8 ; flag for colour set 1 L9687 stb CSSVAL ; set colour set bra L9616 ; set up VDG ; PCLEAR command PCLEAR jsr EVALEXPB ; evaulate number of pages requested tstb ; 0? beq L966D ; brif zero - not allowed cmpb #9 ; more than 8? bhs L966D ; brif so - not allowed lda #6 ; there are 6 "pages" per graphics page mul ; now B is the number of pages to reserve addb GRPRAM ; add to start of graphics memory tfr b,a ; now A is the MSB of the start of free memory ldb #1 ; program memory always starts one above tfr d,y ; save pointer to program memory cmpd ENDGRP ; are we trying to deallocate the current graphics page? lblo LB44A ; brif so subd TXTTAB ; subtract out current start of basic program addd VARTAB ; add in end of program - now D is new top of program tfr d,x ; save new end of program addd #200 ; make some extra space (for stack) subd FRETOP ; see if new top of program fits bhs L966D ; brif there isn't enough space ldu VARTAB ; get end of program stx VARTAB ; save new end of program cmpu VARTAB ; is old end higher? bhs L96D4 ; brif so L96BD lda ,-u ; copy a byte upward sta ,-x cmpu TXTTAB ; at beginning? bne L96BD ; brif not sty TXTTAB ; save new start of program clr -1,y ; there must always be a NUL before the program L96CB jsr LACEF ; re-assign basic program addresses jsr LAD26 ; reset variables and stack jmp LAD9E ; return to interpretation loop L96D4 ldu TXTTAB ; get start of program sty TXTTAB ; save new start of program clr -1,y ; there must be a NUL at the start of the program L96DB lda ,u+ ; move a byte downward sta ,y+ cmpy VARTAB ; at the top of the program? bne L96DB ; brif not bra L96CB ; finish up ; Graphics initialization routine - this really should be up at the start of the ROM with the ; rest of the initialization code. L96E6 ldb #0x1e ; set start of program to 0x1e00 ("PCLEAR 4") stb TXTTAB lda #6 ; graphics memory starts immediately after the screen L96EC sta GRPRAM ; set graphics memory start sta BEGGRP ; set start of current graphics page clra ; set PMODE to 0 sta PMODE lda #16 ; 16 bytes per graphics row sta HORBYT lda #3 ; set foreground colour to 3 sta FORCOL lda #0x0c ; set ending graphics page (for PMODE 0) sta ENDGRP ldx TXTTAB ; get start of program clr -1,x ; make sure there's a NUL before it L9703 jmp LAD19 ; do a "NEW" ; PMODE data table (bytes per row and number of 256 byte pages required for a screen) L9706 fcb 16,6 ; PMODE 0 fcb 32,12 ; PMODE 1 fcb 16,12 ; PMODE 2 fcb 32,24 ; PMODE 3 fcb 32,24 ; PMODE 4 ; Calculate absolute value of vertical coordinate difference L9710 ldd VEREND ; get ending address subd VERBEG ; get difference L9714 bcc L9751 ; brif we didn't carry pshs cc ; save status (C set if start > end) jsr L9DC3 ; negate the difference to be positive puls cc,pc ; restore C and return ; Calculate absolute value of horizontal coordinate difference L971D ldd HOREND ; get end coordinate subd HORBEG ; calculate difference bra L9714 ; turn into absolute value ; PCOPY command PCOPY bsr L973F ; fetch address of the source page pshs d ; save address ldb #0xa5 ; make sure we have TO jsr LB26F bsr L973F ; fetch address of the second page puls x ; get back source tfr d,u ; put destination into a pointer ldy #0x300 ; 0x300 words to copy L9736 ldd ,x++ ; copy a word std ,u++ leay -1,y ; done? bne L9736 ; brif not rts L973F jsr EVALEXPB ; evaluate page number tstb ; zero? beq L9752 ; brif invalid page number ; BUG: this should be deferred until after the address is calculated at which point it should ; be bhs instead of bhi. There should also be a check to make sure the page number is less than ; or equal to 8 above so we don't have to test for overflows below. cmpb TXTTAB ; is page number higher than start of program (BUG!) bhi L9752 ; brif so - error decb ; zero-base the page number lda #6 ; 6 "pages" per graphics page mul ; now we have proper number of "pages" for the offset addb GRPRAM ; add start of graphics memory exg a,b ; put MSB into A, 0 into B. L9751 rts L9752 jmp LB44A ; raise illegal function call ; GET command GET clrb ; GET flag bra L975A ; go on to the main body PUT ldb #1 ; PUT flag L975A stb VD8 ; save GET/PUT flag jsr RVEC22 ; do the RAM hook dance (so Disk Basic can do its thing) L975F cmpa #'@ ; @ before coordinates? bne L9765 ; brif not jsr GETNCH ; eat the @ L9765 jsr L938F ; evaluate start/end coordinates jsr SYNCOMMA ; make sure we have a comma jsr L98CC ; get pointer to array tfr X,D ; save descriptor pointer ldu ,x ; get offset to next descriptor leau -2,u ; move back to array name leau d,u ; point to end of array stu VD1 ; save end of data leax 2,x ; point to number of dimensions ldb ,x ; get dimension count aslb ; two bytes per dimension size abx ; now X points to start of data stx VCF ; save start of array data lda VALTYP ; is it numeric bne L9752 ; brif not clr VD4 ; set default graphic action to PSET jsr GETCCH ; get input character beq L97B7 ; brif no action flag com VD4 ; flag action enabled jsr SYNCOMMA ; make sure there's a comma tst VD8 ; PUT? bne L979A ; brif so ldb #'G ; check for full graphics option jsr LB26F bra L97CA ; handle the rest of the process L979A ldb #5 ; 5 legal actions for PUT ldx #L9839 ; point to action table L979F ldu ,x++ ; get "clear bit" action routine ldy ,x++ ; get "set bit" action routine cmpa ,x+ ; does token match? beq L97AE ; brif so decb ; checked all? bne L979F ; brif not jmp LB277 ; raise error L97AE sty VD5 ; save set bit action address stu VD9 ; save clear bit action address jsr GETNCH ; munch the acton token bra L97CA ; handle rest of process L97B7 ldb #0xf8 ; mask for bottom three bits lda PMODE ; get graphics mode rora ; odd number mode? bcc L97C0 ; brif even ldb #0xfc ; bottom 2 bits mask L97C0 tfr b,a ; save mask andb HORBEG+1 ; round down the start address stb HORBEG+1 anda HOREND+1 ; round down end address sta HOREND+1 L97CA jsr L971D ; get horizontal size bcc L97D3 ; brif end > start ldx HOREND ; switch end in for start stx HORBEG L97D3 std HOREND ; save size jsr L9710 ; calculate vertical size bcc L97DE ; brif end > start ldx VEREND ; swap in vertical end for the start stx VERBEG L97DE std VEREND ; save vertical size lda PMODE ; get graphics mode rora ; even? ldd HOREND ; get difference bcc L97EB ; brif even (2 colour) addd HOREND ; add in size (double it) std HOREND ; save adjusted end size L97EB jsr L9420 ; normalize differences ldd HOREND ; get end coord ldx VEREND ; get end size leax 1,x ; make vertical size inclusive stx VEREND ; save it back tst VD4 ; got "G" or GET action bne L9852 ; brif given lsra ; we're going for whole bytes here rorb lsra rorb lsra rorb addd #1 ; make it inclusive std HOREND ; save new coordinate jsr L9298 ; convert to screen address L9808 ldb HOREND+1 ; get horizontal size pshs x ; save screen position L980C tst VD8 ; get/put flag beq L9831 ; brif get bsr L9823 ; bump array data pointer lda ,u ; copy data from array to screen sta ,x+ L9816 decb ; are we done the row? bne L980C ; brif not puls x ; get screen address jsr L92E9 ; move to next row dec VEREND+1 ; done? bne L9808 ; brif not L9822 rts L9823 ldu VCF ; get array data location leau 1,u ; bump it stu VCF ; save new array data location cmpu VD1 ; did we hit the end of the array? bne L9822 ; brif not L982E jmp LB44A ; raise function call error L9831 lda ,x+ ; get data from screen bsr L9823 ; bump array data pointer sta ,u ; put data in array bra L9816 ; do the loopy thing ; PUT actions L9839 fdb L9894,L989B ; PSET fcb 0xbd fdb L989B,L9894 ; PRESET fcb 0xbe fdb L98B1,L989B ; OR fcb 0xb1 fdb L9894,L98B1 ; AND fcb 0xb0 fdb L98A1,L98A1 ; NOT fcb 0xa8 L9852 addd #1 ; add to horiz difference std HOREND ; save it lda VD8 ; PUT? bne L9864 ; brif so ldu VD1 ; get end of array L985D sta ,-u ; zero out a byte cmpu VCF ; done? bhi L985D ; brif not L9864 jsr L9298 ; get screen address ldb PMODE ; get graphics mode rorb ; even? bcc L986E ; brif so anda #0xaa ; use as pixel mask for 4 colour mode L986E ldb #1 ; set bit probe ldy VCF ; point to start of array data L9873 pshs x,a ; save screen address ldu HOREND ; get horizontal size L9877 pshs u,a ; save horizontal size and pixel mask lsrb ; move bit probe right bcc L9884 ; brif we didn't fall off a byte rorb ; shift carry back in on the left leay 1,y ; move ahead a byte in the array cmpy VD1 ; end of array data? beq L982E ; raise error if so L9884 tst VD8 ; PUT? beq L98A7 ; brif not bitb ,y ; test bit in array beq L9890 ; brif not set jmp [VD5] ; do action routine for bit set L9890 jmp [VD9] ; do action routine for bit clear L9894 coma ; invert mask anda ,x ; read screen data and reset the desired bit sta ,x ; save on screen bra L98B1 L989B ora ,x ; merge pixel mask with screen data (turn on bit) sta ,x ; save on screen bra L98B1 L98A1 eora ,x ; invert the pixel in the screen data sta ,x ; save on screen bra L98B1 L98A7 bita ,x ; is the bit set? beq L98B1 ; brif not - do nothing tfr b,a ; get bit probe ora ,y ; turn on proper bit in data sta ,y L98B1 puls a,u ; get back array address jsr L92ED ; move screen address to the right leau -1,u ; account for consumed pixel cmpu ZERO ; done yet? bne L9877 ; brif not ldx 1,s ; get start of row back lda HORBYT ; get number of bytes per row leax a,x ; move ahead one line puls a ; get back screen pixel mask leas 2,s ; lose the screen pointer dec VEREND+1 ; done all rows? bne L9873 ; brif not rts L98CC jsr LB357 ; evaluate a variable ldb ,-x ; get variable name lda ,-x tfr d,u ; save it ldx ARYTAB ; get start of arrays L98D7 cmpx ARYEND ; end of arrays? lbeq LB44A ; brif not found cmpu ,x ; correct variable? beq L98E8 ; brif so ldd 2,x ; get array size leax d,x ; move to next array bra L98D7 ; check this array L98E8 leax 2,x ; move pointer to the array header rts ; obviously this rts is not needed L98EB rts ; PAINT command PAINT cmpa #'@ ; do we have @ before coords? bne L98F2 ; brif not jsr GETNCH ; eat the @ L98F2 jsr L93B2 ; evaluate coordinates jsr L931D ; normalize coordinates lda #1 ; PSET flag (use working colour) sta SETFLG jsr L9581 ; parse colour and set working colour, etc. ldd WCOLOR ; get working colour and all pixels byte pshs d ; save them jsr GETCCH ; is there anything else? beq L990A ; brif not jsr L9581 ; evaluate border colour L990A lda ALLCOL ; get border colour all pixel byte sta VD8 ; save border colour pixel byte puls d ; get back working colour details std WCOLOR clra ; store a "stop" frame on the stack so PAINT knows when it's finished unwinding pshs u,x,b,a jsr L9522 ; set up starting coordinates jsr L928F ; point to pixel mask routine stu VD9 ; save pixel mask routine jsr L99DF ; paint from current horizontal coordinate to zero (left) beq L9931 ; brif hit border immediately jsr L99CB ; paint from current horizontal coordinate upward (right) lda #1 ; set direction to "down" sta VD7 jsr L99BA ; save "down" frame neg VD7 ; set direction to "up" jsr L99BA ; save "up" frame L9931 sts TMPSTK ; save stack pointer L9934 tst CHGFLG ; did the paint change anything? bne L993B ; brif so lds TMPSTK ; get back stack pointer L993B puls a,b,x,u ; get frame from stack clr CHGFLG ; mark nothing changed sts TMPSTK ; save stack pointer leax 1,x ; move start coordinate right stx HORBEG ; save new coordinate stu VD1 ; save length of line sta VD7 ; save up/down flag beq L98EB ; did we hit the "stop" frame? bmi L9954 ; brif negative going (up)? incb ; bump vertical coordinate cmpb VD6 ; at end? bls L9958 ; brif not clrb ; set vertical to 0 (wrap around) L9954 tstb ; did we wrap? beq L9934 ; do another block if so decb ; move up a row L9958 stb VERBEG+1 ; save vertical coordinate jsr L99DF ; paint from horizontal to 0 beq L996E ; brif we hit the border immediately cmpd #3 ; less than 3 pixels? blo L9969 ; brif so leax -2,x ; move two pixels left bsr L99A1 ; save paint block on the stack L9969 jsr L99CB ; continue painting to the right L996C bsr L99BA ; save paint data frame L996E coma ; complement length of line just painted and add to length of line comb L9970 addd VD1 ; save difference between this line and parent line std VD1 ble L998C ; brif parent line is shorter jsr L9506 ; bump horizontal coordinate jsr L9A12 ; see if we bounced into the border bne L9983 ; brif not border ldd #-1 ; move left bra L9970 ; keep looking L9983 jsr L9514 ; move horizontally left bsr L99C6 ; save horizontal coordinate bsr L99E8 ; paint right bra L996C ; save paint block and do more L998C jsr L9506 ; bump horizontal coordinate leax d,x ; point to right end of parent line stx HORBEG ; set as curent coordinate coma ; get amount we extend past parent line comb subd #1 ble L999E ; brif doesn't extend tfr d,x ; save length of line bsr L99A1 ; save paint frame L999E jmp L9934 L99A1 std VCB ; save number of pixels painted puls y ; get return address ldd HORBEG ; get horizontal coordinate pshs x,b,a ; save horizontal coordinate and pointer lda VD7 ; get up/down flag nega ; reverse it L99AC ldb VERBEG+1 ; get vertical coordainte pshs b,a ; save vertical coord and up/down flag pshs y ; put return address back ldb #2 ; make sure we haven't overflowed memory jsr LAC33 ldd VCB ; get line length back rts L99BA std VCB ; save length of painted line puls y ; get return address ldd HOREND ; get start coord pshs x,b,a ; save horizontal start and length lda VD7 ; get up/down flag bra L99AC ; finish up with the stack L99C6 ldx HORBEG ; save current horizontal coord and save it stx HOREND rts L99CB std VCD ; save number of pixels painted ldy HOREND ; get last horizontal start bsr L99C6 ; save current coordinate sty HORBEG ; save coordinate bsr L99E8 ; paint a line ldx VCD ; get number painted leax d,x ; add to the number painted going the other way addd #1 ; now D is length of line rts L99DF jsr L99C6 ; put starting coordinate in end ldy #L9514 ; decrement horizontal coordinate address bra L99EE ; go paint line L99E8 ldy #L9506 ; increment horizontal coordinate address jsr ,y ; bump coordinate L99EE ldu ZERO ; initialize pixel count ldx HORBEG ; get starting coordinate L99F2 bmi L9A0B ; brif out of range for hoizontal coordinate cmpx VD3 ; at end? bhi L9A0B ; brif right of max pshs u,y ; save counter and inc/dec routine pointer bsr L9A12 ; at border? beq L9A09 ; brif so jsr L9377 ; set pixel to paint colour puls y,u ; restore counter and inc/dec/pointer leau 1,u ; bump number of painted pixels jsr ,y ; inc/dec screen address bra L99F2 ; go do another pixel L9A09 puls y,u ; get back counter and inc/dec routine L9A0B tfr u,d ; save count in D tfr d,x ; and in X subd ZERO ; set flags on D (smaller/faster than cmpd ZERO) rts L9A12 jsr [VD9] ; get the screen address tfr a,b ; save pixel mask andb VD8 ; set pixel to border colour pshs b,a ; save mask and border anda ,x ; mask current pixel into A cmpa 1,s ; does it match border? Z=1 if so puls a,b,pc ; restore mask, border pixel, and return ; PLAY command ; This is here mixed in with the graphics package because it shares some machinery with DRAW. PLAY ldx ZERO ; default values for note length, etc. ldb #1 pshs x,b ; save default values jsr LB156 ; evaluate argument clrb ; enable DA and sound output jsr LA9A2 jsr LA976 L9A32 jsr LB654 ; fetch PLAY string details bra L9A39 ; go evaluate the string L9A37 puls b,x ; get back play string details L9A39 stb VD8 ; save length of string beq L9A37 ; brif end of string stx VD9 ; save start of string lbeq LA974 ; brif NULL string - disable sound and return L9A43 tst VD8 ; have anything left? beq L9A37 ; brif not jsr L9B98 ; get command character cmpa #'; ; command separator? beq L9A43 ; brif so - ignore it cmpa #'' ; '? beq L9A43 ; brif so - ignore it cmpa #'X ; execuate sub string? lbeq L9C0A ; brif so - handle it bsr L9A5C ; handle other commands bra L9A43 ; look for more stuff L9A5C cmpa #'O ; octave? bne L9A6D ; brif not ldb OCTAVE ; get current octave incb ; 1-base it bsr L9AC0 ; get value if present decb ; zero-base it cmpb #4 ; valid octave? bhi L9ACD ; raise error if not stb OCTAVE ; save new octave rts L9A6D cmpa #'V ; volume? bne L9A8B ; brif not ldb VOLHI ; get current high volume limit lsrb ; shift 2 bits right (DA is 6 bits in high bits) lsrb subb #31 ; subtract out mid value offset bsr L9AC0 ; read argument cmpb #31 ; maximum range is 31 bhi L9ACD ; brif out of range aslb ; adjust back in range aslb pshs b ; save new volume ldd #0x7e7e ; midrange value for both high and low adda ,s ; add new volume to high limit subb ,s+ ; subtract volume from low limit std VOLHI ; save new volume limits (sets high and low amplitudes) rts L9A8B cmpa #'L ; note length? bne L9AB2 ; brif not ldb NOTELN ; get current length bsr L9AC0 ; read parameter tstb ; resulting length 0? beq L9ACD ; brif so - problem stb NOTELN ; save new length clr DOTVAL ; reset note timer scale factor L9A9A bsr L9A9F ; check for dot bcc L9A9A ; brif there was one rts L9A9F tst VD8 ; check length beq L9AAD ; brif zero jsr L9B98 ; get command character cmpa #'. ; dot? beq L9AAF ; brif so jsr L9BE2 ; move input back and bump length L9AAD coma ; set C to indicate nothing found rts L9AAF inc DOTVAL ; bump number of dots rts L9AB2 cmpa #'T ; tempo? bne L9AC3 ; brif not ldb TEMPO ; get current tempo bsr L9AC0 ; parse tempo argument tstb ; 0? beq L9ACD ; brif so - invalid stb TEMPO ; save new tempo rts L9AC0 jmp L9BAC ; evaluate various operators L9AC3 cmpa #'P ; pause? bne L9AEB ; brif not jsr L9CCB ; evaluate parameter tstb ; is the pause number 0? bne L9AD0 ; brif not L9ACD jmp LB44A ; raise FC error L9AD0 lda DOTVAL ; save current volume and note scale ldx VOLHI pshs x,a lda #0x7e ; drop DA to mid range sta VOLHI sta VOLLOW clr DOTVAL bsr L9AE7 ; go play a "silence" puls a,x ; restore volume and note scale sta DOTVAL stx VOLHI rts L9AE7 clr ,-s ; set not number 0 bra L9B2B ; go play it L9AEB cmpa #'N ; N for "note"? bne L9AF2 ; brif not - it's optional jsr L9B98 ; skip the "N" L9AF2 cmpa #'A ; is it a valid note? blo L9AFA ; brif not cmpa #'G ; is it above the note range? bls L9AFF ; brif not - valid note L9AFA jsr L9BBE ; evaluate a number bra L9B22 ; process note value L9AFF suba #'A ; normalize note number to 0 ldx #L9C5B ; point to note number lookup table ldb a,x ; get not number tst VD8 ; any command characters left? beq L9B22 ; brif not jsr L9B98 ; get character cmpa #'# ; sharp? beq L9B15 ; brif so cmpa #'+ ; also sharp? bne L9B18 ; brif not L9B15 incb ; add one half tone bra L9B22 L9B18 cmpa #'- ; flat? bne L9B1F ; brif not decb ; subtract one half tone bra L9B22 L9B1F jsr L9BE2 ; back up command pointer L9B22 decb ; adjust note number (zero base it) cmpb #11 ; is it valid? bhi L9ACD ; raise error if not pshs b ; save note value ldb NOTELN ; get note length L9B2B lda TEMPO ; get tempo value mul ; calculate note duration std VD5 ; save duration leau 1,s ; point to where the stack goes after we're done lda OCTAVE ; get current octave cmpa #1 ; 0 or 1? bhi L9B64 ; brif not ldx #L9C62 ; point to delay table ldb #2*12 ; 24 bytes per octave mul ; now we have the base address abx ; now X points to the octave base puls b ; get back note value aslb ; two bytes per delay abx ; now we're pointing to the delay leay ,x ; save pointer to note value bsr L9B8C ; calculate note timer value std PLYTMR ; set timer for note playing (IRQ will count this down) L9B49 bsr L9B57 ; set to mid range and delay lda VOLHI ; get high value bsr L9B5A ; set to high value and delay bsr L9B57 ; set to mid range and delay lda VOLLOW ; get low value bsr L9B5A ; set to low value and delay bra L9B49 ; do it again (IRQ will break the loop) L9B57 lda #0x7e ; mid value for DA with RS232 marking nop ; a delay to fine tune frequencies L9B5A sta PIA1 ; set DA ldx ,y ; get delay value L9B5F leax -1,x ; count down bne L9B5F ; brif not done yet rts L9B64 ldx #L9C92-2*12 ; point to delay table for octaves 2+ ldb #12 ; 12 bytes per octave mul ; now we have the offset to the desired octave abx ; now we point to the start of the octave puls b ; get back note value abx ; now we point to the delay value bsr L9B8C ; calculate timer value std PLYTMR ; set play timer (IRQ counts this down) L9B72 bsr L9B80 ; send mid value and delay lda VOLHI ; get high value bsr L9B83 ; send high value and delay bsr L9B80 ; send low value and delay lda VOLLOW ; get low value bsr L9B83 ; send low value and delay bra L9B72 ; do it again (IRQ will break the loop) L9B80 lda #0x7e ; mid range value with RS232 marking nop ; fine tuning delay L9B83 sta PIA1 ; set DA lda ,x ; get delay value L9B88 deca ; count down bne L9B88 ; brif not done rts L9B8C ldb #0xff ; base timer value lda DOTVAL ; get number of dots beq L9B97 ; use default value if 0 adda #2 ; add in constant timer factor mul ; multiply scale by base lsra ; divide by two - each increment will increase note timer by 128 rorb L9B97 rts L9B98 pshs x ; save register L9B9A tst VD8 ; do we have anything left? beq L9BEB ; brif not - raise error ldx VD9 ; get parsing address lda ,x+ ; get character stx VD9 ; save pointer dec VD8 ; account for character consumed cmpa #0x20 ; space? beq L9B9A ; brif so - skip it puls x,pc ; restore register and return L9BAC bsr L9B98 ; get character cmpa #'+ ; add one? beq L9BEE ; brif so cmpa #'- ; subtract one? beq L9BF2 ; brif so cmpa #'> ; double? beq L9BFC ; brif so cmpa #'< ; halve? beq L9BF7 ; brif so L9BBE cmpa #'= ; variable equate? beq L9C01 ; brif so jsr L90AA ; clear carry if numeric bcs L9BEB ; brif not numeric clrb ; initialize value to 0 L9BC8 suba #'0 ; remove ASCII bias sta VD7 ; save digit lda #10 ; make room for digit mul tsta ; did we overflow 8 bits? bne L9BEB ; brif so addb VD7 ; add in digit bcs L9BEB ; brif that overflowed tst VD8 ; more digits? beq L9BF1 ; brif not jsr L9B98 ; get character jsr L90AA ; clear carry if numeric bcc L9BC8 ; brif another digit L9BE2 inc VD8 ; unaccount for character just read ldx VD9 ; move pointer back leax -1,x stx VD9 rts L9BEB jmp LB44A ; raise FC error L9BEE incb ; bump param beq L9BEB ; brif overflow L9BF1 rts L9BF2 tstb ; already zero? beq L9BEB ; brif so - underflow decb ; decrease parameter rts L9BF7 tstb ; already at 0? beq L9BEB ; brif so - raise error lsrb ; halve it rts L9BFC tstb ; will it overflow? bmi L9BEB ; brif so aslb ; double it rts L9C01 pshs u,y ; save registers bsr L9C1B ; interpret command string as a variable jsr LB70E ; convert it to an 8 bit number puls y,u,pc ; restore registers and return L9C0A jsr L9C1B ; evaluate expression in command string ldb #2 ; room for 4 bytes? jsr LAC33 ldb VD8 ; get the command length and pointer ldx VD9 pshs x,b ; save them jmp L9A32 ; go process the sub string L9C1B ldx VD9 ; get command pointer pshs x ; save it jsr L9B98 ; get input character jsr LB3A2 ; set carry if not alpha bcs L9BEB ; brif not a variable reference L9C27 jsr L9B98 ; get command character cmpa #'; ; semicolon? bne L9C27 ; keep scanning if not puls x ; get back start of variable string ldu CHARAD ; get current interpreter input pointer pshs u ; save it stx CHARAD ; point interpreter at command string jsr LB284 ; evaluate expression as string puls x ; restore interpeter input pointer stx CHARAD rts ; The bit of Extended Basic's IRQ routine that handles PLAY. Note that everything after ; clr PLYTMR+1 could be replaced with a simple lds 8,s followed by rts. L9C3E clra ; make sure DP is set to 0 tfr a,dp ldd PLYTMR ; is PLAY running? lbeq LA9BB ; brif not - transfer control on the Color Basic's routine subd VD5 ; subtract out the interval std PLYTMR ; save new timer value bhi L9C5A ; brif it isn't <= 0 clr PLYTMR ; disable the timer clr PLYTMR+1 puls a ; get saved CC lds 7,s ; set stack to saved U value anda #0x7f ; clear E flag (to return minimal state) pshs a ; set fake "FIRQ" stack frame L9C5A rti L9C5B fcb 10,12,1,3,5,6,8 ; table of half tone numbers for notes A-G L9C62 fdb 0x01a8,0x0190,0x017a,0x0164 ; delays for octave 1 fdb 0x0150,0x013d,0x012b,0x011a fdb 0x010a,0x00fb,0x00ed,0x00df fdb 0x00d3,0x00c7,0x00bb,0x00b1 ; delays for octave 2 fdb 0x00a6,0x009d,0x0094,0x008b fdb 0x0083,0x007c,0x0075,0x006e L9C92 fcb 0xa6,0x9c,0x93,0x8b ; delays for octave 3 fcb 0x83,0x7b,0x74,0x6d fcb 0x67,0x61,0x5b,0x56 fcb 0x51,0x4c,0x47,0x43 ; delays for octave 4 fcb 0x3f,0x3b,0x37,0x34 fcb 0x31,0x2e,0x2b,0x28 fcb 0x26,0x23,0x21,0x1f ; delays for octave 5 fcb 0x1d,0x1b,0x19,0x18 fcb 0x16,0x14,0x13,0x12 ; DRAW command DRAW ldx ZERO ; create an empty "DRAW" frame ldb #1 pshs x,b stb SETFLG ; set to "PSET" mode stx VD5 ; clear update and draw flag jsr L959A ; set active colour byte jsr LB156 ; evaluate command string L9CC6 jsr LB654 ; fetch command string details bra L9CD3 ; interpret the command string L9CCB jsr L9B98 ; fetch command character jmp L9BBE ; evaluate a number L9CD1 puls b,x ; get previously saved command string L9CD3 stb VD8 ; save length counter beq L9CD1 ; brif end of string stx VD9 ; save pointer lbeq L9DC7 ; brif overall end of command L9CDD tst VD8 ; are we at the end of the string? beq L9CD1 ; brif so - return to previous string jsr L9B98 ; get command character cmpa #'; ; semicolon? beq L9CDD ; brif so - ignore it cmpa #'' ; '? beq L9CDD ; brif so - ignore that too cmpa #'N ; update position toggle? bne L9CF4 ; brif not com VD5 ; toggle update position flag bra L9CDD ; get on for another command L9CF4 cmpa #'B ; blank flag? bne L9CFC ; brif not com VD6 ; toggle blank flag bra L9CDD ; get on for another command L9CFC cmpa #'X ; substring? lbeq L9D98 ; brif so - execute command cmpa #'M ; move draw position? lbeq L9E32 ; brif so pshs a ; save command character ldb #1 ; default value if no number follows tst VD8 ; is there something there? beq L9D21 ; brif not jsr L9B98 ; get character jsr LB3A2 ; set C if not alpha pshs cc ; save alpha state jsr L9BE2 ; move back pointer puls cc ; get back alpha flag bcc L9D21 ; brif it's alpha bsr L9CCB ; evaluate a number L9D21 puls a ; get command back cmpa #'C ; color change? beq L9D4F ; brif so cmpa #'A ; angle? beq L9D59 ; brif so cmpa #'S ; scale? beq L9D61 ; brif so cmpa #'U ; up? beq L9D8F ; brif so cmpa #'D ; down? beq L9D8C ; brif so cmpa #'L ; left? beq L9D87 ; brif so cmpa #'R ; right? beq L9D82 ; brif so suba #'E ; normalize the half cardinals to 0 beq L9D72 ; brif E (45°) deca ; F (135°?) beq L9D6D ; brif so deca ; G (225°?) beq L9D7B ; brif so deca ; H (315°?) beq L9D69 ; brif so L9D4C jmp LB44A ; raise FC error L9D4F jsr L955D ; adjust colour for PMODE stb FORCOL ; save new foreground colour jsr L959A ; set up working colour and all pixels byte L9D57 bra L9CDD ; go process another command L9D59 cmpb #4 ; only 3 angles are valid bhs L9D4C ; brif not valid stb ANGLE ; save new angle bra L9D57 ; go process another command L9D61 cmpb #63 ; only 64 scale values are possible bhs L9D4C ; brif out of range stb SCALE ; save new scale factor bra L9D57 ; go process another command L9D69 clra ; make horizontal negative bsr L9DC4 skip1 L9D6D clra ; keep horizontal distance positive tfr d,x ; make horizontal distance and vertical distance the same bra L9DCB ; go do the draw thing L9D72 clra ; zero extend horizontal distance tfr d,x ; set it as vertical bsr L9DC4 ; negate horizontal distance exg d,x ; swap directions (vertical is now negative) bra L9DCB ; go do the draw thing L9D7B clra ; zero extend horizontal distance tfr d,x ; copy horizontal to vertical bsr L9DC4 ; negate horizontal bra L9DCB ; go do the drawing thing L9D82 clra ; zero extend horizontal distance L9DB3 ldx ZERO ; no vertical distance bra L9DCB ; go do the drawing things L9D87 clra ; zero extend horizontal bsr L9DC4 ; negate horizontal bra L9DB3 ; zero out vertical and do the drawing thing L9D8C clra ; zero extend distance bra L9D92 ; make the distance vertical and zero out horizontal L9D8F clra ; zero extend distance bsr L9DC4 ; negate distance L9D92 ldx ZERO ; zero out vertical distance exg x,d ; swap vertical and horizontal bra L9DCB ; go do the drawing thing L9D98 jsr L9C1B ; evaluate substring expression ldb #2 ; is there enough room for the state? jsr LAC33 ldb VD8 ; save current command string state ldx VD9 pshs x,b jmp L9CC6 ; go evaluate the sub string L9DA9 ldb SCALE ; get scale factor beq L9DC8 ; brif zero - default to full size clra ; zero extend exg d,x ; put distance somewhere useful sta ,-s ; save MS of distance bpl L9DB6 ; brif positive distance bsr L9DC3 ; negate the distance L9DB6 jsr L9FB5 ; multiply D and X tfr u,d ; save ms bytes in D lsra ; divide by 2 rorb L9DBD lsra ; ...divide by 4 rorb tst ,s+ ; negative distance? bpl L9DC7 ; brif it was positive L9DC3 nega ; negate D L9DC4 negb sbca #0 L9DC7 rts L9DC8 tfr x,d ; copy unchanged sitance to D rts L9DCB pshs b,a ; save horizontal distance bsr L9DA9 ; apply scale factor to vertical puls x ; get horizontal distance pshs b,a ; save scaled vertical bsr L9DA9 ; apply scale to horizontal puls x ; get back vertical distance ldy ANGLE ; get draw angle and scale pshs y ; save them L9DDC tst ,s ; is there an angle? beq L9DE8 ; brif no angle exg x,d ; swap distances bsr L9DC3 ; negate D dec ,s ; account for one tick around the rotation bra L9DDC ; see if we're there yet L9DE8 puls y ; get angle and scale back ldu ZERO ; default end position (horizontal) is 0 addd HORDEF ; add default horizontal to horizontal distance bmi L9DF2 ; brif we went negative tfr d,u ; save calculated end coordindate L9DF2 tfr x,d ; get vertical distance somewhere useful ldx ZERO ; default vertical end is 0 addd VERDEF ; add distance to default vertical start bmi L9DFC ; brif negative - use 0 tfr d,x ; save calculated end coordinate L9DFC cmpu #256 ; is horizontal in range? blo L9E05 ; brif su ldu #255 ; maximize it L9E05 cmpx #192 ; is vertical in range? blo L9E0D ; brif so ldx #191 ; maximize it L9E0D ldd HORDEF ; set starting coordinates for the line std HORBEG ldd VERDEF std VERBEG stx VEREND ; set end coordinates stu HOREND tst VD5 ; are we updating position? bne L9E21 ; brif not stx VERDEF ; update default coordinates stu HORDEF L9E21 jsr L9420 ; normalize coordindates tst VD6 ; are we drawing something? bne L9E2B ; brif not jsr L94A1 ; draw the line L9E2B clr VD5 ; reset draw and update flags clr VD6 jmp L9CDD ; do another command L9E32 jsr L9B98 ; get a command character pshs a ; save it jsr L9E5E ; evaluate horizontal distance pshs b,a ; save it jsr L9B98 ; get character cmpa #', ; comma between coordinates? lbne L9D4C ; brif not - raise error jsr L9E5B ; evaluate vertical distance tfr d,x ; save vertical distance puls u ; get horizontal distance puls a ; get back first command character cmpa #'+ ; was it + at start? beq L9E56 ; brif +; treat values as positive cmpa #'- ; was it -? bne L9DFC ; brif not - treat it as absolute L9E56 tfr u,d ; put horizontal distance somewhere useful jmp L9DCB ; move draw position (relative) L9E5B jsr L9B98 ; get input character L9E5E cmpa #'+ ; leading +? beq L9E69 ; brif so cmpa #'- ; leading -? beq L9E6A ; brif so - negative jsr L9BE2 ; move pointer back one L9E69 clra ; 0 for +, nonzero for - L9E6A pshs a ; save sign flag jsr L9CCB ; evaluate number puls a ; get sign flag tsta ; negative? beq L9E78 ; brif not clra ; zero extend and negate negb sbca #0 L9E78 rts ; Table of sines and cosines for CIRCLE L9E79 fdb 0x0000,0x0001 ; subarc 0 fdb 0xfec5,0x1919 ; subarc 1 fdb 0xfb16,0x31f2 ; subarc 2 fdb 0xf4fb,0x4a51 ; subarc 3 fdb 0xec84,0x61f9 ; subarc 4 fdb 0xe1c7,0x78ae ; subarc 5 fdb 0xd4dc,0x8e3b ; subarc 6 fdb 0xc5e5,0xa269 ; subarc 7 fdb 0xb506,0xb506 ; subarc 8 ; CIRCLE command ; The circle is drawn as a 64 sided polygon (64 LINE commands essentially) CIRCLE cmpa #'@ ; is there an @ before coordinates? bne L9EA3 ; brif not jsr GETNCH ; eat the @ L9EA3 jsr L9522 ; get max coordinates for screen jsr L93B2 ; parse coordinates for circle centre jsr L931D ; normalize the start coordinates ldx ,u ; get horizontal coordinate stx VCB ; save it ldx 2,u ; get vertical coordinate stx VCD ; saveit jsr SYNCOMMA ; make sure we have a comma jsr LB73D ; evaluate radius expression ldu #VCF ; point to temp storage stx ,u ; save radius jsr L9320 ; normalize radius lda #1 ; default to PSET sta SETFLG jsr L9581 ; evaluate the colour expression ldx #0x100 ; height/width default value jsr GETCCH ; is there a ratio? beq L9EDF ; brif not jsr SYNCOMMA ; make sure we have a comma jsr LB141 ; evaluate the ratio lda FP0EXP ; multiply ratio by 256 adda #8 sta FP0EXP jsr LB740 ; evaluate ratio to X (fraction part in LSB) L9EDF lda PMODE ; get graphics mode bita #2 ; is it even? beq L9EE9 ; brif so tfr x,d ; double the ratio leax d,x L9EE9 stx VD1 ; save height/width ratio ldb #1 ; set the SET flag to PSET stb SETFLG stb VD8 ; set first time flag (set to 0 after arc drawn) jsr L9FE2 ; evaluate circle starting point (octant, subarc) pshs b,a ; save startpoint jsr L9FE2 ; evaluate circle end point (octant, subarc) std VD9 ; save endp oint puls a,b L9EFD pshs b,a ; save current circle position ldx HOREND ; move end coordinates to start coordinates stx HORBEG ldx VEREND stx VERBEG ldu #L9E79+2 ; point to sine/cosine table anda #1 ; even octant? beq L9F11 ; brif so negb ; convert 0-7 to 8-1 for odd octants addb #8 L9F11 aslb ; four bytes per table entry aslb leau b,u ; point to correct table entry pshs u ; save sine/cosine table entry pointer jsr L9FA7 ; calculate horizontal offset puls u ; get back table entry pointer leau -2,u ; move to cosine entry pshs x ; save horizontal offset jsr L9FA7 ; calculate vertical offset puls y ; put horizontal in Y lda ,s ; get octant number anda #3 ; is it 0 or 4? beq L9F31 ; brif so cmpa #3 ; is it 3 or 7? beq L9F31 ; brif so exg x,y ; swap horizontal and vertical L9F31 stx HOREND ; save horizontal offset tfr y,x ; put vertical offset in X ldd VD1 ; get height/width ratio jsr L9FB5 ; multiply vertical by h/w ratio tfr y,d ; save the product to D tsta ; did it overflow? lbne LB44A ; brif so stb VEREND ; save vertical coordinate MSB tfr u,d ; get LSW of product sta VEREND+1 ; save LSB of integer part (we have 8 bits of fraction in the ratio) lda ,s ; get octant cmpa #2 ; is it 0 or 1? blo L9F5B ; brif so cmpa #6 ; is it 6 or 7? bhs L9F5B ; brif so ldd VCB ; get horizontal centre subd HOREND ; subtract horizontal displacement bcc L9F68 ; brif we didn't overflow the screen clra ; zero out coordinate if we overflowed the screen clrb bra L9F68 L9F5B ldd VCB ; get horizontal coordinate of the centre addd HOREND ; add displacement bcs L9F66 ; brif overlod cmpd VD3 ; larger than max horizontal coord? blo L9F68 ; brif not L9F66 ldd VD3 ; maximize the coordinate L9F68 std HOREND ; save horizontal ending coordainte lda ,s ; get octant cmpa #4 ; is it 0-3? blo L9F7A ; brif so ldd VCD ; get vertical coordinate of centre subd VEREND ; subtract displacement bcc L9F87 ; brif we didn't overflow the screen clra ; minimize to top of screen clrb bra L9F87 L9F7A ldd VCD ; get vertical centre coordinate addd VEREND ; add displacement bcs L9F85 ; brif we overflowed the screen cmpd VD5 ; did we go past max coordinate? blo L9F87 ; brif not L9F85 ldd VD5 ; maximize the coordinate L9F87 std VEREND ; save end coordinate tst VD8 ; check first time flag bne L9F8F ; do not draw if first time through (it was setting start coord) bsr L9FDF ; draw the line L9F8F puls a,b ; get arc number and sub arc lsr VD8 ; get first time flag value (and clear it!) bcs L9F9A ; do not check for end point after drawing for first coordinate cmpd VD9 ; at end point? beq L9FA6 ; brif drawing finished L9F9A incb ; bump arc counter cmpb #8 ; done 8 arcs? bne L9FA3 ; brif not inca ; bump octant clrb ; reset subarc number anda #7 ; make sure octant number stays in 0-7 range L9FA3 jmp L9EFD ; go do another arc L9FA6 rts L9FA7 ldx VCF ; get radius ldd ,u ; get sine/cosine table entry beq L9FB4 ; brif 0 - offset = radius subd #1 ; adjust values to correct range bsr L9FB5 ; multiply radius by sine/cosine tfr y,x ; resturn result in X L9FB4 rts L9FB5 pshs u,y,x,b,a ; save registers and reserve temp space clr 4,s ; reset overflow byte (YH) lda 3,s ; calcuate B*XL mul std 6,s ; put in "U" ldd 1,s ; calculate B*XH mul addb 6,s ; accumluate with previous product adca #0 std 5,s ; save in YL,UH ldb ,s ; calculate A*XL lda 3,s mul addd 5,s ; accumulate with previous partical product std 5,s ; save in YL,UH bcc L9FD4 ; brif no carry inc 4,s ; bump YH for carry L9FD4 lda ,s ; calculate A*XH ldb 2,s mul addd 4,s ; accumulate with previous partial product std 4,s ; save in Y (we can't have a carry here) puls a,b,x,y,u,pc ; restore multiplicands and return results L9FDF jmp L94A1 ; go draw a line L9FE2 clrb ; default arc number (0) jsr GETCCH ; is there something there for a value? beq L9FF8 ; brif not jsr SYNCOMMA ; evaluate , + expression jsr LB141 lda FP0EXP ; multiply by 64 adda #6 sta FP0EXP jsr LB70E ; get integer value of circle fraction andb #0x3f ; max value of 63 L9FF8 tfr b,a ; save arc value in A to calculate octant andb #7 ; calculate subarc lsra ; calculate octant lsra lsra rts