Mercurial > hg > index.cgi

comparison exbas11.s @ 0:605ff82c4618

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Initial check in with cleaned up sources This is the initial check in the source code in a state where it builds byte accurate copies of all the various ROM versions included.
author William Astle <lost@l-w.ca>
date Sat, 08 Dec 2018 19:57:01 -0700
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:605ff82c4618
1 *pragma nolist
2 include defs.s
3 ; These are the entry points in the Color Basic ROM which are used the the Extended Basic ROM.
4 ; They are included here in order to keep the Extended Basic ROM separate from the Color Basic
5 ; ROM.
6 BAWMST EQU 0xA0E8
7 CLOAD EQU 0xA498
8 CSAVE EQU 0xA44C
9 DATA EQU 0xAEE0
10 EVALEXPB EQU 0xB70B
11 GIVABF EQU 0xB4F4
12 INT EQU 0xBCEE
13 LA0E2 EQU 0xA0E2
14 LA171 EQU 0xA171
15 LA176 EQU 0xA176
16 LA35F EQU 0xA35F
17 LA3ED EQU 0xA3ED
18 LA406 EQU 0xA406
19 LA429 EQU 0xA429
20 LA42D EQU 0xA42D
21 LA444 EQU 0xA444
22 LA491 EQU 0xA491
23 LA505 EQU 0xA505
24 LA578 EQU 0xA578
25 LA59A EQU 0xA59A
26 LA5A5 EQU 0xA5A5
27 LA5AE EQU 0xA5AE
28 LA5C7 EQU 0xA5C7
29 LA5E4 EQU 0xA5E4
30 LA616 EQU 0xA616
31 LA619 EQU 0xA619
32 LA635 EQU 0xA635
33 LA644 EQU 0xA644
34 LA648 EQU 0xA648
35 LA65F EQU 0xA65F
36 LA7E9 EQU 0xA7E9
37 LA974 EQU 0xA974
38 LA976 EQU 0xA976
39 LA9A2 EQU 0xA9A2
40 LA9BB EQU 0xA9BB
41 LAC1E EQU 0xAC1E
42 LAC33 EQU 0xAC33
43 LAC46 EQU 0xAC46
44 LAC60 EQU 0xAC60
45 LAC73 EQU 0xAC73
46 LAC7C EQU 0xAC7C
47 LAC9D EQU 0xAC9D
48 LACA8 EQU 0xACA8
49 LACEF EQU 0xACEF
50 LACF1 EQU 0xACF1
51 LAD01 EQU 0xAD01
52 LAD19 EQU 0xAD19
53 LAD21 EQU 0xAD21
54 LAD26 EQU 0xAD26
55 LAD33 EQU 0xAD33
56 LAD9E EQU 0xAD9E
57 LADC6 EQU 0xADC6
58 LADD4 EQU 0xADD4
59 LADEB EQU 0xADEB
60 LAE15 EQU 0xAE15
61 LAED2 EQU 0xAED2
62 LAF67 EQU 0xAF67
63 LAFA4 EQU 0xAFA4
64 LB035 EQU 0xB035
65 LB141 EQU 0xB141
66 LB143 EQU 0xB143
67 LB146 EQU 0xB146
68 LB156 EQU 0xB156
69 LB158 EQU 0xB158
70 LB244 EQU 0xB244
71 LB262 EQU 0xB262
72 LB267 EQU 0xB267
73 LB26A EQU 0xB26A
74 LB26F EQU 0xB26F
75 LB277 EQU 0xB277
76 LB284 EQU 0xB284
77 LB2CE EQU 0xB2CE
78 LB357 EQU 0xB357
79 LB35C EQU 0xB35C
80 LB3A2 EQU 0xB3A2
81 LB44A EQU 0xB44A
82 LB4F3 EQU 0xB4F3
83 LB50F EQU 0xB50F
84 LB518 EQU 0xB518
85 LB51A EQU 0xB51A
86 LB56D EQU 0xB56D
87 LB643 EQU 0xB643
88 LB654 EQU 0xB654
89 LB657 EQU 0xB657
90 LB659 EQU 0xB659
91 LB69B EQU 0xB69B
92 LB6A4 EQU 0xB6A4
93 LB6AD EQU 0xB6AD
94 LB70E EQU 0xB70E
95 LB734 EQU 0xB734
96 LB738 EQU 0xB738
97 LB73D EQU 0xB73D
98 LB740 EQU 0xB740
99 LB7C2 EQU 0xB7C2
100 LB958 EQU 0xB958
101 LB95C EQU 0xB95C
102 LB99F EQU 0xB99F
103 LB9AC EQU 0xB9AC
104 LB9AF EQU 0xB9AF
105 LB9B4 EQU 0xB9B4
106 LB9B9 EQU 0xB9B9
107 LB9C2 EQU 0xB9C2
108 LBA1C EQU 0xBA1C
109 LBA3A EQU 0xBA3A
110 LBA92 EQU 0xBA92
111 LBAC5 EQU 0xBAC5
112 LBACA EQU 0xBACA
113 LBB48 EQU 0xBB48
114 LBB5C EQU 0xBB5C
115 LBB6A EQU 0xBB6A
116 LBB82 EQU 0xBB82
117 LBB8F EQU 0xBB8F
118 LBC14 EQU 0xBC14
119 LBC2F EQU 0xBC2F
120 LBC35 EQU 0xBC35
121 LBC4C EQU 0xBC4C
122 LBC5F EQU 0xBC5F
123 LBC6D EQU 0xBC6D
124 LBCA0 EQU 0xBCA0
125 LBCC8 EQU 0xBCC8
126 LBD99 EQU 0xBD99
127 LBDB6 EQU 0xBDB6
128 LBDBB EQU 0xBDBB
129 LBDC0 EQU 0xBDC0
130 LBDC5 EQU 0xBDC5
131 LBDCC EQU 0xBDCC
132 LBDD9 EQU 0xBDD9
133 LBEC0 EQU 0xBEC0
134 LBEC5 EQU 0xBEC5
135 LBEE9 EQU 0xBEE9
136 LBEF0 EQU 0xBEF0
137 LBEFF EQU 0xBEFF
138 LBFA6 EQU 0xBFA6
139 LET EQU 0xAF89
140 PUTCHR EQU 0xA282
141 SIN EQU 0xBF78
142 SNDBLK EQU 0xA7F4
143 STRINOUT EQU 0xB99C
144 SYNCOMMA EQU 0xB26D
145 WRLDR EQU 0xA7D8
146 *pragma list
147 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
148 ; EXTENDED COLOR BASIC ROM
149 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
150 org EXBAS
151 fcc 'EX' ; magic number that Color Basic uses to identify the presence of Extended Basic
152 L8002 ldx #L80DE ; point to command interpretation table information
153 ldu #COMVEC+10 ; point to command interpretation table location
154 ldb #10 ; 10 bytes to move
155 jsr LA59A ; copy command interpretation table
156 ldx #LB277 ; initialize Disk Basic's entries to error
157 stx 3,u
158 stx 8,u
159 ldx #XIRQSV ; set up IRQ service routine
160 stx IRQVEC+1
161 ldx ZERO ; reset the TIMER value
162 stx TIMVAL
163 jsr XVEC18 ; do a bunch of initialization
164 ldd #0x2c05 ; initialize DLOAD baud rate constant and timeout
165 std DLBAUD
166 ldx #USR0 ; set up pointer to USR routine addresses
167 stx USRADR
168 ldu #LB44A ; set up USR routine addresses to "FC error"
169 ldb #10 ; there are 10 routines
170 L8031 stu ,x++ ; set a routine to FC error
171 decb ; done all?
172 bne L8031 ; brif not
173 lda #0x7e ; op code of JMP extended (for RAM hook intialization)
174 sta RVEC20 ; command interpretation loop
175 ldx #XVEC20
176 stx RVEC20+1
177 sta RVEC15 ; expression evaluation
178 ldx #XVEC15
179 stx RVEC15+1
180 sta RVEC19 ; number parsing
181 ldx #XVEC19
182 stx RVEC19+1
183 sta RVEC9 ; PRINT
184 ldx #XVEC9
185 stx RVEC9+1
186 sta RVEC17 ; error handler
187 ldx #XVEC17
188 stx RVEC17+1
189 sta RVEC4 ; generic input
190 ldx #XVEC4
191 stx RVEC4+1
192 sta RVEC3 ; generic output
193 ldx #XVEC3
194 stx RVEC3+1
195 sta RVEC8 ; close file
196 ldx #XVEC8
197 stx RVEC8+1
198 sta RVEC23 ; tokenize line
199 ldx #XVEC23
200 stx RVEC23+1
201 sta RVEC18 ; RUN
202 ldx #XVEC18
203 stx RVEC18+1
204 sta EXPJMP ; exponentiation
205 ldx #L8489
206 stx EXPJMP+1
207 jsr L96E6 ; initialize graphics stuff
208 lda PIA0+3 ; enable 60Hz interrupt
209 ora #1
210 sta PIA0+3
211 ldx #'D*256+'K ; magic number for a Disk Basic ROM
212 cmpx DOSBAS ; do we have a Disk Basic ROM?
213 lbeq DOSBAS+2 ; brif so - launch it
214 andcc #0xaf ; enable interrupts
215 ldx #L80E8-1 ; show sign on message
216 jsr STRINOUT
217 ldx #XBWMST ; install warm start handler
218 stx RSTVEC
219 jmp LA0E2 ; set up warm start flag and launch immediate mode
220 ; Extended Basic warm start code
221 XBWMST nop ; flag to mark routine as valid
222 clr PLYTMR ; cancel any PLAY command in progress
223 clr PLYTMR+1
224 lda PIA0+3 ; enable 60Hz interrupt
225 ora #1
226 sta PIA0+3
227 jmp BAWMST ; let Color Basic's warm start process run
228 ; This code is to fix the famous PCLEAR bug. It replaces dead code in the 1.0 ROM. This patch corrects
229 ; the input pointer so that it points to the correct place after the program has been relocated by
230 ; PCLEAR instead of continuing with something that, in the best case, is a syntax error.
231 L80D0 lda CURLIN ; immediate mode?
232 inca
233 beq L80DD ; brif so
234 tfr y,d ; save offset to D
235 subd TXTTAB ; see how far into the program we are
236 addd CHARAD ; now adjust the input pointer based on that
237 std CHARAD ; save corrected input pointer
238 L80DD rts
239 L80DE fcb 25 ; 25 Extended Basic commands
240 fdb L8183 ; reserved word table (commands)
241 fdb L813C ; interpretation handler (commands)
242 fcb 14 ; 14 Extended Basic functions
243 fdb L821E ; reserved word table (functions)
244 fdb L8168 ; function handler
245 L80E8 fcc 'EXTENDED COLOR BASIC 1.1'
246 fcb 0x0d
247 fcc 'COPYRIGHT (C) 1982 BY TANDY'
248 fcb 0x0d
249 fcc 'UNDER LICENSE FROM MICROSOFT'
250 fcb 0x0d,0x0d,0x00
251 ; Extended Basic command interpretation loop
252 L813C cmpa #0xcb ; is it an Extended Basic command?
253 bhi L8148 ; brif not
254 ldx #L81F0 ; point to dispatch table
255 suba #0xb5 ; normalize the token number so 0 is the first entry
256 jmp LADD4 ; go transfer control to the command
257 L8148 cmpa #0xff ; is it a function token?
258 beq L8154 ; brif so - for MID$()=, TIMER=
259 cmpa #0xcd ; is it a token for a keyword that isn't a command?
260 bls L8165 ; brif so - error for USING and FN
261 jmp [COMVEC+23] ; transfer control to Disk Basic if it is present
262 L8154 jsr GETNCH ; get token after the function flag
263 cmpa #0x90 ; MID$?
264 lbeq L86D6 ; brif so (substring replacement)
265 cmpa #0x9f ; TIMER?
266 lbeq L8960 ; brif so - TIMER setting
267 jsr RVEC22 ; do a RAM hook in case something wants to extend this
268 L8165 jmp LB277 ; we have nothing valid here
269 ; Function handler
270 L8168 cmpb #2*33 ; is it a valid Extended Basic function?
271 bls L8170 ; brif so
272 jmp [COMVEC+28] ; transfer control to Disk Basic if it is present
273 L8170 subb #2*20 ; normalize Extended Basic functions to 0
274 cmpb #2*8 ; Above HEX$?
275 bhi L817D ; brif so - we don't pre-evaluate an argument
276 pshs b ; save token value
277 jsr LB262 ; evaluate the function parameter
278 puls b ; get back token value
279 L817D ldx #L8257 ; point to dispatch table
280 jmp LB2CE ; go transfer control to the function
281 ; Reserved words (commands)
282 L8183 fcs 'DEL' ; 0xb5
283 fcs 'EDIT' ; 0xb6
284 fcs 'TRON' ; 0xb7
285 fcs 'TROFF' ; 0xb8
286 fcs 'DEF' ; 0xb9
287 fcs 'LET' ; 0xba
288 fcs 'LINE' ; 0xbb
289 fcs 'PCLS' ; 0xbc
290 fcs 'PSET' ; 0xbd
291 fcs 'PRESET' ; 0xbe
292 fcs 'SCREEN' ; 0xbf
293 fcs 'PCLEAR' ; 0xc0
294 fcs 'COLOR' ; 0xc1
295 fcs 'CIRCLE' ; 0xc2
296 fcs 'PAINT' ; 0xc3
297 fcs 'GET' ; 0xc4
298 fcs 'PUT' ; 0xc5
299 fcs 'DRAW' ; 0xc6
300 fcs 'PCOPY' ; 0xc7
301 fcs 'PMODE' ; 0xc8
302 fcs 'PLAY' ; 0xc9
303 fcs 'DLOAD' ; 0xca
304 fcs 'RENUM' ; 0xcb
305 fcs 'FN' ; 0xcc
306 fcs 'USING' ; 0xcd
307 ; Dispatch table (commands)
308 L81F0 fdb DEL ; 0xb5 DEL
309 fdb EDIT ; 0xb6 EDIT
310 fdb TRON ; 0xb7 TRON
311 fdb TROFF ; 0xb8 TROFF
312 fdb DEF ; 0xb9 DEF
313 fdb LET ; 0xba LET (note: implemented by Color Basic!)
314 fdb LINE ; 0xbb LINE
315 fdb PCLS ; 0xbc PCLS
316 fdb PSET ; 0xbd PSET
317 fdb PRESET ; 0xbe PRESET
318 fdb SCREEN ; 0xbf SCREEN
319 fdb PCLEAR ; 0xc0 PCLEAR
320 fdb COLOR ; 0xc1 COLOR
321 fdb CIRCLE ; 0xc2 CIRCLE
322 fdb PAINT ; 0xc3 PAINT
323 fdb GET ; 0xc4 GET
324 fdb PUT ; 0xc5 PUT
325 fdb DRAW ; 0xc6 DRAW
326 fdb PCOPY ; 0xc7 PCOPY
327 fdb PMODETOK ; 0xc8 PMODE
328 fdb PLAY ; 0xc9 PLAY
329 fdb DLOAD ; 0xca DLOAD
330 fdb RENUM ; 0xcb RENUM
331 ; Reserved words (functions)
332 L821E fcs 'ATN' ; 0x94
333 fcs 'COS' ; 0x95
334 fcs 'TAN' ; 0x96
335 fcs 'EXP' ; 0x97
336 fcs 'FIX' ; 0x98
337 fcs 'LOG' ; 0x99
338 fcs 'POS' ; 0x9a
339 fcs 'SQR' ; 0x9b
340 fcs 'HEX$' ; 0x9c
341 fcs 'VARPTR' ; 0x9d
342 fcs 'INSTR' ; 0x9e
343 fcs 'TIMER' ; 0x9f
344 fcs 'PPOINT' ; 0xa0
345 fcs 'STRING$' ; 0xa1
346 ; Dispatch table (functions)
347 L8257 fdb ATN ; 0x94 ATN
348 fdb COS ; 0x95 COS
349 fdb TAN ; 0x96 TAN
350 fdb EXP ; 0x97 EXP
351 fdb FIX ; 0x98 FIX
352 fdb LOG ; 0x99 LOG
353 fdb POS ; 0x9a POS
354 fdb SQR ; 0x9b SQR
355 fdb HEXDOL ; 0x9c HEX$
356 fdb VARPTRTOK ; 0x9d VARPTR
357 fdb INSTR ; 0x9e INSTR
358 fdb TIMER ; 0x9f TIMER
359 fdb PPOINT ; 0xa0 PPOINT
360 fdb STRING ; 0xa1 STRING$
361 ; Generic output handler
362 XVEC3 tst DEVNUM ; screen?
363 lbeq L95AC ; brif so - force text screen active
364 pshs b ; save register
365 ldb DEVNUM ; get output device
366 cmpb #-3 ; check for DLOAD
367 puls b ; restore register
368 bne L8285 ; brif not DLOAD
369 leas 2,s ; bail out of output handler if DLOAD
370 L8285 rts
371 ; Close file handler. This corrects a bug in Color Basic 1.0 which didn't handle writing the
372 ; end of file block correctly. That bug is fixed in Color Basic 1.1 so this isn't required
373 ; if a recent enough version of Color Basic is installed.
374 XVEC8 lda DEVNUM ; get device number
375 inca ; is it tape?
376 bne L8285 ; brif not - we aren't going to mess with it
377 lda FILSTA ; get tape file status
378 cmpa #2 ; output file?
379 bne L8285 ; brif not
380 lda CINCTR ; is there anything waiting to be written out?
381 bne L8285 ; brif so - mainline code will handle it properly
382 clr DEVNUM ; reset output to screen
383 leas 2,s ; don't return to mainline code
384 jmp LA444 ; write EOF block
385 ; RUN handler - sets up some Extended Basic stuff to defaults at program start
386 XVEC18 ldd #0xba42 ; initialize PLAY volume
387 std VOLHI
388 lda #2 ; set PLAY tempo to 2, PLAY octave to 3
389 sta TEMPO
390 sta OCTAVE
391 asla ; set default note length to 5
392 sta NOTELN
393 clr DOTVAL ; don't do any note length extension
394 ldd ZERO ; initialize DRAW angle and scale to default 1
395 std ANGLE
396 ldb #128 ; initialize horizontal and vertical default coordinates to the middle of the screen
397 std HORDEF
398 ldb #96
399 std VERDEF
400 rts
401 ; Command interpretation loop handler; we need to intercept this to implement TRON/TROFF
402 XVEC20 leas 2,s ; don't return to the mainline code
403 L82BB andcc #0xaf ; make sure interrupts are running
404 jsr LADEB ; do a BREAK/pause check
405 ldx CHARAD ; save input pointer
406 stx TINPTR
407 lda ,x+ ; get current input character
408 beq L82CF ; brif end of line
409 cmpa #': ; statement separator?
410 beq L82F1 ; brif so
411 jmp LB277 ; raise error we got here with extra junk
412 L82CF lda ,x++ ; get first byte of next line address
413 sta ENDFLG ; use it to set "END" flag to "END"
414 bne L82D8 ; brif not end of program
415 jmp LAE15 ; go do the "END"
416 L82D8 ldd ,x+ ; get line number of next line (and leave pointer one before line text)
417 std CURLIN ; set current line number
418 stx CHARAD ; save input pointer
419 lda TRCFLG ; are we tracing?
420 beq L82F1 ; brif not
421 lda #'[ ; show opening marker for TRON line number
422 jsr PUTCHR
423 lda CURLIN ; restore MSB of line number
424 jsr LBDCC ; show line number
425 lda #'] ; show closing marker for TRON line number
426 jsr PUTCHR
427 L82F1 jsr GETNCH ; get the start of the statement
428 tfr cc,b ; save status flags
429 cmpa #0x98 ; is it CSAVE?
430 beq L8316 ; brif so - go to Extended Basic patch (adds CSAVEM)
431 cmpa #0x97 ; is it CLOAD?
432 beq L8311 ; brif so - go to Extended Basic patch (adds multi-origin binaries)
433 tfr b,cc ; restore character status
434 jsr LADC6 ; go process command
435 bra L82BB ; restart interpretation loop
436 ; Tokenizaton handler. This is actually a hack to intercept CLOAD and CSAVE during immediate mode by causing the
437 ; tokenization routine to return to the interpretation loop above instead of the mainline interpretation loop. This
438 ; is necessary because the first command encountered on a line in immediate mode is executed BEFORE the interpretation
439 ; loop RAM hook is called. This patch doesn't actually affect tokenization itself at all.
440 XVEC23 ldx 2,s ; get return address of caller to the tokenizer
441 cmpx #LAC9D ; is it coming from immediate mode prior to executing the line?
442 bne L8310 ; brif not
443 ldx #L82F1 ; force return to Extended Basic's main loop patch above
444 stx 2,s
445 L8310 rts
446 ; These two patches are set up this way so that control can be transferred back to the original Color Basic
447 ; implementations if the Extended Basic addons are not triggered.
448 L8311 jsr L8C62 ; transfer control to Extended Basic's CLOAD handler
449 bra L82BB ; go do another command
450 L8316 bsr L831A ; go do Extended Basic's CSAVE handler
451 bra L82BB ; go do another command
452 ; Extended Basic's CSAVE handler which implements CSAVEM (which Color Basic does not have)
453 L831A jsr GETNCH ; get character after CSAVE
454 cmpa #'M ; is it CSAVEM?
455 lbne CSAVE ; brif not - Color Basic can handle this
456 jsr GETNCH ; eat the "M"
457 jsr LA578 ; parse file name
458 bsr L836C ; get start address
459 stx CASBUF+13 ; save it in file header
460 bsr L836C ; get end address
461 cmpx 2,s ; compare to start address
462 lblo LB44A ; brif end address is before the start address
463 bsr L836C ; get execution address
464 stx CASBUF+11 ; put in file header
465 jsr GETCCH ; are we at the end of the commmand?
466 bne L8310 ; brif not
467 lda #2 ; file type to machine language
468 ldx ZERO ; set to binary and single block
469 jsr LA65F ; write header
470 clr FILSTA ; mark any open tape file closed
471 inc BLKTYP ; set block type to data
472 jsr WRLDR ; write a data leader
473 ldx 4,s ; get starting address
474 L834D stx CBUFAD ; set start of data address
475 lda #255 ; try a full length block by default
476 sta BLKLEN
477 ldd 2,s ; get ending address
478 subd CBUFAD ; see how much is left
479 bhs L835E ; brif we have more to write
480 leas 6,s ; clean up stack
481 jmp LA491 ; write EOF block
482 L835E cmpd #255 ; do we have a full block left?
483 bhs L8367 ; brif so
484 incb ; set block size to remainder
485 stb BLKLEN
486 L8367 jsr SNDBLK ; write a data block
487 bra L834D ; go see if we have more to write
488 L836C jsr SYNCOMMA ; make sure we have a comma
489 jsr LB73D ; evaluate unsigned expression to X
490 ldu ,s ; get return address
491 stx ,s ; save result on stack
492 tfr u,pc ; return to caller
493 ; COS function
494 COS ldx #L83AB ; point to PI/2 constant
495 jsr LB9C2 ; add to argument ( cos(x) = sin((pi/2)+x) )
496 L837E jmp SIN ; now calculate sin((pi/2)+x)
497 ; TAN function. This is determined by the identity TAN(X) = SIN(X)/COS(X)
498 TAN jsr LBC2F ; save FPA0 in FPA3
499 clr RELFLG ; reset quadrant flag
500 bsr L837E ; calculate SIN(x)
501 ldx #V4A ; save result in FPA5
502 jsr LBC35
503 ldx #V40 ; get back original argument
504 jsr LBC14
505 clr FP0SGN ; force result positive
506 lda RELFLG ; get quadrant flag
507 bsr L83A6 ; calculate COS(x)
508 tst FP0EXP ; did we get 0 for COS(x)
509 lbeq LBA92 ; brif so - overflow
510 ldx #V4A ; point to sin(x)
511 L83A3 jmp LBB8F ; divide the sin(x) value by the cos(x) value
512 L83A6 pshs a ; save sign flag
513 jmp LBFA6 ; expand polynomial
514 L83AB fcb 0x81,0x49,0x0f,0xda,0xa2 ; pi/2 constant
515 ; ATN function (inverse tangent). There are two calculation streams used to improve precision.
516 ; One if the parameter is >= 1.0 and the other if it is < 1.0
517 ATN lda FP0SGN ; get sign of argument
518 pshs a ; save it
519 bpl L83B8 ; brif positive
520 bsr L83DC ; flip sign of argument
521 L83B8 lda FP0EXP ; get exponent
522 pshs a ; save it
523 cmpa #0x81 ; exponent for 1.0
524 blo L83C5 ; brif less - value is less than 1.0
525 ldx #LBAC5 ; point to FP constant 1.0
526 bsr L83A3 ; calculate reciprocal
527 L83C5 ldx #L83E0 ; point to polynomical coefficients
528 jsr LBEF0 ; expand polynomial
529 puls a ; get exponent of argument
530 cmpa #0x81 ; did we do a reciprocal calculation?
531 blo L83D7 ; brif not
532 ldx #L83AB ; subtract result from pi/2 if we did
533 jsr LB9B9
534 L83D7 puls a ; get sign of original
535 tsta ; was it positive?
536 bpl L83DF ; brif so
537 L83DC jmp LBEE9 ; flip sign of result
538 L83DF rts
539 ; Chebyshev modified taylor series coefficients for inverse tangent. Note that these diverge quite significantly
540 ; 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
541 ; so on. These modified coefficients yield reasonable accuracy for the precision available, presumably with
542 ; fewer coefficients.
543 L83E0 fcb 11 ; 12 coefficients
544 fcb 0x76,0xb3,0x83,0xbd,0xd3 ; -0.000684793912
545 fcb 0x79,0x1e,0xf4,0xa6,0xf5 ; 0.00485094216
546 fcb 0x7b,0x83,0xfc,0xb0,0x10 ; -0.0161117018
547 fcb 0x7c,0x0c,0x1f,0x67,0xca ; 0.0342096381
548 fcb 0x7c,0xde,0x53,0xcb,0xc1 ; -0.0542791328
549 fcb 0x7d,0x14,0x64,0x70,0x4c ; 0.0724571965
550 fcb 0x7d,0xb7,0xea,0x51,0x7a ; -0.0898023954
551 fcb 0x7d,0x63,0x30,0x88,0x7e ; 0.110932413
552 fcb 0x7e,0x92,0x44,0x99,0x3a ; -0.142839808
553 fcb 0x7e,0x4c,0xcc,0x91,0xc7 ; 0.199999121
554 fcb 0x7f,0xaa,0xaa,0xaa,0x13 ; -0.333333316
555 fcb 0x81,0x00,0x00,0x00,0x00 ; 1.0
556 ; Chebyshev modified taylor series coefficients for the ln(x)/ln(2) (base 2 log of x)
557 L841D fcb 3 ; four coefficients
558 fcb 0x7f,0x5e,0x56,0xcb,0x79 ; 0.434255942 from (2/7)/ln(2)
559 fcb 0x80,0x13,0x9b,0x0b,0x64 ; 0.576584541 from (2/5)/ln(2)
560 fcb 0x80,0x76,0x38,0x93,0x16 ; 0.961800759 from (2/3)/ln(2)
561 fcb 0x82,0x38,0xaa,0x3b,0x20 ; 2.88539007 from 2/ln(2)
562 L8432 fcb 0x80,0x35,0x04,0xf3,0x34 ; 1/sqrt(2)
563 L8437 fcb 0x81,0x35,0x04,0xf3,0x34 ; sqrt(2)
564 L843C fcb 0x80,0x80,0x00,0x00,0x00 ; -0.5
565 L8441 fcb 0x80,0x31,0x72,0x17,0xf8 ; ln(2)
566 ; LOG function (natural log, ln)
567 ; FP representation is of the form A*2^B. Thus, the log routine determines the value of
568 ; ln(A*2^B).
569 ;
570 ; ln(A*2^B) = ln(A) + ln(2^B) = ln(A) + B*ln(2) = (ln(A)/ln(2) + B)*ln(2), OR:
571 ; (log2(A) + B)*ln(2)
572 ; Now if we write A as A*(sqrt(2)/sqrt(2)), we haven't changed anything so:
573 ; (log2(A*sqrt(2)/sqrt(2)) + B)*ln(2) = (log2(A*sqrt(2)) - log2(sqrt(2)) + B) * ln(2)
574 ; which gives: (-1/2 + log2(A*sqrt(2)) + B) * ln(2)
575 ;
576 ; Everything except log2(A*sqrt(2)) is either constant or trivial.
577 ;
578 ; What the actual code below feeds into the modified taylor series is actually:
579 ; 1 - (sqrt(2)/(A + sqrt(2)) which algebra reveals to be (A*sqrt(2)-1)/(A*sqrt(2)+1)
580 ;
581 ; Thus, the code is using (A*sqrt(2)-1)/(A*sqrt(2)+1) instead of A*sqrt(2) as one would
582 ; expect from the identities. However, the modified coefficients in the series above
583 ; could be correcting for that or the introduced error was deemed acceptable.
584 ; NOTE: this routine does NOT return 0 for LOG(1)
585 LOG jsr LBC6D ; get status of FPA0
586 lble LB44A ; brif <= 0 - logarithms don't exist in that case
587 ldx #L8432 ; point to 1/sqrt(2)
588 lda FP0EXP ; get exponent of argument
589 suba #0x80 ; remove bias
590 pshs a ; save it for later
591 lda #0x80 ; force exponent to 0 (this turns FPA0 into A in the above description)
592 sta FP0EXP
593 jsr LB9C2 ; add 1/sqrt(2) to A
594 ldx #L8437 ; point to sqrt(2)
595 jsr LBB8F ; divide that by FPA0
596 ldx #LBAC5 ; point to 1.0
597 jsr LB9B9 ; subtract result from 1.0: Now FPA0 is 1-(sqrt(2)/(A+1/sqrt(2)))
598 ldx #L841D ; point to coefficients
599 jsr LBEF0 ; expand polynomial (calculate base 2 log of modified argument)
600 ldx #L843C ; point to -0.5
601 jsr LB9C2 ; add result
602 puls b ; get original exponent back
603 jsr LBD99 ; add B to FPA0
604 ldx #L8441 ; point to ln(2)
605 jmp LBACA ; multiply by ln(2) which gives us the result in base e
606 ; SQR function (square root) - returns the principle root (positive)
607 SQR jsr LBC5F ; move argument to FPA1 (first argument for exponentiation)
608 ldx #LBEC0 ; point to 0.5 (exponent for square root)
609 jsr LBC14 ; set up second argument to exponentiation (the exponent)
610 ; Exponentiation operator
611 ; This is calculated as A^x = e^(x*ln(A)) where A is in FPA1 and x is in FPA0
612 L8489 beq EXP ; do "EXP" if exponent is 0 (this will catch 0^0)
613 tsta ; check that the base is not 0
614 bne L8491 ; brif base is not 0
615 jmp LBA3A ; 0^(nonzero) is 0
616 L8491 ldx #V4A ; save exponent (to FPA5)
617 jsr LBC35
618 clrb ; result sign will default to positive
619 lda FP1SGN ; check if base is positive
620 bpl L84AC ; brif so
621 jsr INT ; convert exponent to integer
622 ldx #V4A ; point to original expoent
623 lda FP1SGN ; get sign of FPA1
624 jsr LBCA0 ; compare original exponent with truncated one
625 bne L84AC ; brif not equal
626 coma ; flip sign
627 ldb CHARAC ; get LS byte of integer exponent (result sign flag)
628 L84AC jsr LBC4C ; copy FPA1 (base) to FPA0 (A = sign)
629 pshs b ; save result sign
630 jsr LOG ; get natural log of the base
631 ldx #V4A ; multiply the log by the exponent
632 jsr LBACA
633 bsr EXP ; now raise e to the resulting power
634 puls a ; get result sign
635 rora ; brif it was negative
636 lbcs LBEE9 ; brif negative - flip sign
637 rts
638 L84C4 fcb 0x81,0x38,0xaa,0x3b,0x29 ; 1.44269504 (correction factor for exponential function)
639 ; Chebyshev modified taylor series coefficients for e^x
640 L84C9 fcb 7 ; eight coefficients
641 fcb 0x71,0x34,0x58,0x3e,0x56 ; 1/(7!*(CF^7))
642 fcb 0x74,0x16,0x7e,0xb3,0x1b ; 1/(6!*(CF^6))
643 fcb 0x77,0x2f,0xee,0xe3,0x85 ; 1/(5!*(CF^5))
644 fcb 0x7a,0x1d,0x84,0x1c,0x2a ; 1/(4!*(CF^4))
645 fcb 0x7c,0x63,0x59,0x58,0x0a ; 1/(3!*(CF^3))
646 fcb 0x7e,0x75,0xfd,0xe7,0xc6 ; 1/(2!*(CF^2))
647 fcb 0x80,0x31,0x72,0x18,0x10 ; 1/(1!*(CF^1))
648 fcb 0x81,0x00,0x00,0x00,0x00 ; 1
649 ; EXP function (e^x)
650 EXP ldx #L84C4 ; point to correction factor
651 jsr LBACA ; multiply it
652 jsr LBC2F ; save corrected argument to FPA3
653 lda FP0EXP ; get exponent of FPA0
654 cmpa #0x88 ; is it too big?
655 blo L8504 ; brif not
656 L8501 jmp LBB5C ; to 0 (underflow) or overflow error
657 L8504 jsr INT ; convert argument to an integer
658 lda CHARAC ; get ls byte of integer
659 adda #0x81 ; was argument 127? if so, the OV error; adds bias
660 beq L8501
661 deca ; adjust for the extra +1 above
662 pshs a ; save integer exponent
663 ldx #V40 ; get fractional part of argument
664 jsr LB9B9
665 ldx #L84C9 ; point to coefficients
666 jsr LBEFF ; evaluate polynomial on the fractional part
667 clr RESSGN ; force result to be positive
668 puls a ; get back original exponent
669 jsr LBB48 ; add original exponent to the fractional result
670 rts
671 ; FIX function (truncate/round toward 0) (NOTE: INT() always rounds down so INT(-0.5) gives -1 but FIX(-0.5) gives 0)
672 FIX jsr LBC6D ; get status of argument
673 bmi L852C ; brif negative
674 L8529 jmp INT ; do regular "int" if positive
675 L852C com FP0SGN ; flip the sign
676 bsr L8529 ; do "INT" on this
677 jmp LBEE9 ; flip the sign back
678 ; EDIT command
679 EDIT jsr L89AE ; get line number
680 leas 2,s ; we're not going to return to the main loop
681 L8538 lda #1 ; "LIST" flag
682 sta VD8 ; set to list the line
683 jsr LAD01 ; find line number
684 lbcs LAED2 ; brif line wasn't found
685 jsr LB7C2 ; go unpack the line into the buffer
686 tfr y,d ; calculate the actual length of the line
687 subd #LINBUF+2
688 stb VD7 ; save line length (it will only be 8 bits)
689 L854D ldd BINVAL ; get the line number
690 jsr LBDCC ; display it
691 jsr LB9AC ; put a space after it
692 ldx #LINBUF+1 ; point to iput uffer
693 ldb VD8 ; are we listing?
694 bne L8581 ; brif so
695 L855C clrb ; reset digit accumulator
696 L855D jsr L8687 ; get a keypress
697 jsr L90AA ; set carry if not numeric
698 bcs L8570 ; brif not a number
699 suba #'0 ; remove ASCII bias
700 pshs a ; save digit value
701 lda #10 ; multiply accumulator by 10
702 mul
703 addb ,s+ ; add in new digit
704 bra L855D ; go check for another digit
705 L8570 subb #1 ; this converts 0 to 1, but *only* 0 to 1
706 adcb #1
707 cmpa #'A ; abort?
708 bne L857D ; brif not
709 jsr LB958 ; to a CR
710 bra L8538 ; restart EDIT process
711 L857D cmpa #'L ; list?
712 bne L858C ; brif not
713 L8581 bsr L85B4 ; list the line
714 clr VD8 ; reset to "not listing"
715 jsr LB958 ; do a CR
716 bra L854D ; start editing
717 L858A leas 2,s ; lose return address
718 L858C cmpa #0x0d ; ENTER?
719 bne L859D ; brif not
720 bsr L85B4 ; echo out the line
721 L8592 jsr LB958 ; do a CR
722 ldx #LINBUF+1 ; reset input pointer to start of buffer
723 stx CHARAD
724 jmp LACA8 ; join immediate mode to replace the line in the program
725 L859D cmpa #'E ; exit?
726 beq L8592 ; brif so - end edit with no echo
727 cmpa #'Q ; quit?
728 bne L85AB ; brif not
729 jsr LB958 ; do a CR
730 jmp LAC73 ; go to immediate mode with no fanfare - no changes saved
731 L85AB bsr L85AF ; go do commands
732 bra L855C ; go handle another command
733 L85AF cmpa #0x20 ; space?
734 bne L85C3 ; brif not
735 skip2
736 L85B4 ldb #LBUFMX-1 ; display up to a whole line
737 L85B6 lda ,x ; get buffer chracter
738 beq L85C2 ; brif end of line
739 jsr PUTCHR ; output character
740 leax 1,x ; move to next character
741 decb ; done?
742 bne L85B6 ; brif not
743 L85C2 rts
744 L85C3 cmpa #'D ; delete?
745 bne L860F ; brif not
746 L85C7 tst ,x ; end of line?
747 beq L85C2 ; brif so - can't delete
748 bsr L85D1 ; remove a character
749 decb ; done all requested?
750 bne L85C7 ; brif not
751 rts
752 L85D1 dec VD7 ; account for character being removed
753 leay -1,x ; set pointer and compensate for increment below
754 L85D5 leay 1,y ; move to next character
755 lda 1,y ; get next character
756 sta ,y ; move it forward
757 bne L85D5 ; brif we didn't hit the end of the buffer
758 rts
759 L85DE cmpa #'I ; insert?
760 beq L85F5 ; brif so
761 cmpa #'X ; extend?
762 beq L85F3 ; brif so
763 cmpa #'H ; "hack"?
764 bne L8646 ; brif not
765 clr ,x ; mark current location as end of line
766 tfr x,d ; calculate new line length
767 subd #LINBUF+2
768 stb VD7 ; save new length
769 L85F3 bsr L85B4 ; display the line
770 L85F5 jsr L8687 ; read a character
771 cmpa #0x0d ; ENTER?
772 beq L858A ; brif so - terminate entry
773 cmpa #0x1b ; ESC?
774 beq L8625 ; brif so - back to command mode
775 cmpa #0x08 ; backspace?
776 bne L8626 ; brif no
777 cmpx #LINBUF+1 ; are we at the start of the buffer?
778 beq L85F5 ; brif so - it's a no-op
779 bsr L8650 ; move pointer back one, do a BS
780 bsr L85D1 ; remove character from the buffer
781 bra L85F5 ; go handle more input
782 L860F cmpa #'C ; change?
783 bne L85DE ; brif not
784 L8613 tst ,x ; is there something to change?
785 beq L8625 ; brif not
786 jsr L8687 ; get a key stroke
787 bcs L861E ; brif valid key
788 bra L8613 ; try again if invalid key
789 L861E sta ,x+ ; put new character in the buffer
790 bsr L8659 ; echo it
791 decb ; changed number requested?
792 bne L8613 ; brif not
793 L8625 rts
794 L8626 ldb VD7 ; get length of line
795 cmpb #LBUFMX-1 ; at maximum line length?
796 bne L862E ; brif not
797 bra L85F5 ; process another input character
798 L862E pshs x ; save input pointer
799 L8630 tst ,x+ ; are we at the end of the line?
800 bne L8630 ; brif not
801 L8634 ldb ,-x ; get character before current pointer, move back
802 stb 1,x ; move it forward
803 cmpx ,s ; at the original buffer pointer?
804 bne L8634 ; brif not
805 leas 2,s ; remove saved buffer pointer
806 sta ,x+ ; save input character in newly made hole
807 bsr L8659 ; echo it
808 inc VD7 ; bump line length counter
809 bra L85F5 ; go handle more stuff
810 L8646 cmpa #0x08 ; backspace?
811 bne L865C ; brif not
812 L864A bsr L8650 ; move pointer back, echo BS
813 decb ; done enough of them?
814 bne L864A ; brif not
815 rts
816 L8650 cmpx #LINBUF+1 ; at start of buffer?
817 beq L8625 ; brif so
818 leax -1,x ; move pointer back
819 lda #0x08 ; character to echo - BS
820 L8659 jmp PUTCHR ; echo character to screen
821 L865C cmpa #'K ; "kill"?
822 beq L8665 ; brif so
823 suba #'S ; search?
824 beq L8665 ; brif so
825 rts
826 L8665 pshs a ; save kill/search flag
827 bsr L8687 ; read target
828 pshs a ; save search character
829 L866B lda ,x ; get current character in buffer
830 beq L8685 ; brif end of line - nothing more to search
831 tst 1,s ; is it KILL?
832 bne L8679 ; brif so
833 bsr L8659 ; echo the character
834 leax 1,x ; move ahead
835 bra L867C ; check next character
836 L8679 jsr L85D1 ; remove character from buffer
837 L867C lda ,x ; get character in buffer
838 cmpa ,s ; are we at the target?
839 bne L866B ; brif not
840 decb ; have we found enough of them?
841 bne L866B ; brif not
842 L8685 puls y,pc ; clean up stack and return to main EDIT routine
843 L8687 jsr LA171 ; get input from the generic input handler (will show the cursor)
844 cmpa #0x7f ; graphics (or DEL)?
845 bhs L8687 ; brif so - ignore it
846 cmpa #0x5f ; SHIFT-UP?
847 bne L8694 ; brif not
848 lda #0x1b ; replace with ESC
849 L8694 cmpa #0x0d ; carriage return?
850 beq L86A6 ; brif so (C=0)
851 cmpa #0x1b ; ESC
852 beq L86A6 ; brif so (C=0)
853 cmpa #0x08 ; backspace?
854 beq L86A6 ; brif so (C=0)
855 cmpa #32 ; control code?
856 blo L8687 ; brif control code - try again
857 orcc #1 ; set C for "valid" (printable) character
858 L86A6 rts
859 ; TRON and TROFF commands
860 TRON skip1lda ; load flag with nonzero for trace enabled (and skip next)
861 TROFF clra ; clear flag for trace disabled
862 sta TRCFLG ; save trace status
863 rts
864 ; POS function
865 POS lda DEVNUM ; get original device number
866 pshs a ; save it for later
867 jsr LA5AE ; fetch device number
868 jsr LA406 ; check for open file
869 jsr LA35F ; set up print parameters
870 ldb DEVPOS ; get current line position for the device
871 jmp LA5E4 ; return position in B as unsigned
872 ; VARPTR function
873 VARPTRTOK jsr LB26A ; make sure we have (
874 ldd ARYEND ; get address of end of arrays
875 pshs d ; save it
876 jsr LB357 ; parse variable descriptor
877 jsr LB267 ; make sure there is a )
878 puls d ; get original end of arrays
879 exg x,d ; swap original end of arrays and the discovered variable pointer
880 cmpx ARYEND ; did array end move (variable created?)
881 bne L8724 ; brif so (FC error)
882 jmp GIVABF ; return the pointer (NOTE: as signed)
883 ; MID$() assignment; note that this cannot make the string longer or shorter and if the replacement is shorter
884 ; than the specified size, only the number of characters actually in the replacement will be used.
885 L86D6 jsr GETNCH ; eat the MID$ token
886 jsr LB26A ; force (
887 jsr LB357 ; evaluate the variable
888 pshs x ; save variable descriptor
889 ldd 2,x ; point to start of original string
890 cmpd FRETOP ; is it in string space?
891 bls L86EB ; brif not
892 subd MEMSIZ ; is it still in string space (top end)?
893 bls L86FD ; brif so
894 L86EB ldb ,x ; get length of original string
895 jsr LB56D ; allocate space in string space
896 pshs x ; save pointer to string space
897 ldx 2,s ; get to original string descriptor
898 jsr LB643 ; move the string into string space
899 puls x,u ; get new string address and string descriptor
900 stx 2,u ; save new data address for the string
901 pshs u ; save descriptor address again
902 L86FD jsr LB738 ; evaluate ",start"
903 pshs b ; save start offset
904 tstb ; is start 0?
905 beq L8724 ; brif so - strings offsets are 1-based
906 ldb #255 ; default use the entire string
907 cmpa #') ; end of parameters?
908 beq L870E ; brif so
909 jsr LB738 ; evaluate ",length"
910 L870E pshs b ; save length
911 jsr LB267 ; make sure we have a )
912 ldb #0xb3 ; make sure we have =
913 jsr LB26F
914 bsr L8748 ; evaluate replacement string
915 tfr x,u ; save replacement string address
916 ldx 2,s ; get original string descriptor
917 lda ,x ; get length of original string
918 suba 1,s ; subtract start position
919 bhs L8727 ; brif within the string - insert replacement
920 L8724 jmp LB44A ; raise illegal function call
921 L8727 inca ; A is now number of characters to the right of the position parameter
922 cmpa ,s ; compare to length desired
923 bhs L872E ; brif new length fits
924 sta ,s ; only use as much of the length as will fit
925 L872E lda 1,s ; get position offset
926 exg a,b ; swap replacement length and position
927 ldx 2,x ; point to original string address
928 decb ; we work with 0-based offsets
929 abx ; now X points to start of replacement
930 tsta ; replacing 0?
931 beq L8746 ; brif so - done
932 cmpa ,s ; is replacement shorter than the hole?
933 bls L873F ; brif so
934 lda ,s ; use copy the maximum number specified
935 L873F tfr a,b ; save number to move in B
936 exg u,x ; swap pointers so they are right for the routine
937 jsr LA59A ; copy string data
938 L8746 puls a,b,x,pc ; clean up stack and return
939 L8748 jsr LB156 ; evaluate expression
940 jmp LB654 ; make sure it's a string and return string details
941 ; STRING$ function
942 STRING jsr LB26A ; make sure we have (
943 jsr EVALEXPB ; evaluate repeat count (error if > 255)
944 pshs b ; save repeat count
945 jsr SYNCOMMA ; make sure there's a comma
946 jsr LB156 ; evaluate the thing to repeat
947 jsr LB267 ; make sure we have a )
948 lda VALTYP ; is it string?
949 bne L8768 ; brif so
950 jsr LB70E ; get 8 bit character code
951 bra L876B ; use that
952 L8768 jsr LB6A4 ; get first character of string
953 L876B pshs b ; save repeat character
954 ldb 1,s ; get repeat count
955 jsr LB50F ; reserve space for the string
956 puls a,b ; get character and repeat count
957 beq L877B ; brif NULL string
958 L8776 sta ,x+ ; put character into string
959 decb ; put enough?
960 bne L8776 ; brif not
961 L877B jmp LB69B ; return the newly created string
962 ; INSTR function
963 INSTR jsr LB26A ; evaluate (
964 jsr LB156 ; evaluate first argument
965 ldb #1 ; default start position is 1 (start of string)
966 pshs b ; save start position
967 lda VALTYP ; get type of first argument
968 bne L879C ; brif string - use default starting position
969 jsr LB70E ; convert first argument into string offset
970 stb ,s ; save offset
971 beq L8724 ; brif starting at 0 - not allowed
972 jsr SYNCOMMA ; make sure there's a comma
973 jsr LB156 ; evaluate the search string
974 jsr LB146 ; make sure it *is* a string
975 L879C ldx FPA0+2 ; get search string descriptor
976 pshs x ; save it
977 jsr SYNCOMMA ; make sure we have a comma
978 jsr L8748 ; evalute the target string
979 pshs x,b ; save address and length of target string
980 jsr LB267 ; make sure we have a )
981 ldx 3,s ; get search string address
982 jsr LB659 ; get string details
983 pshs b ; save search string length
984 cmpb 6,s ; compare length of search string to the start
985 blo L87D9 ; brif start position is beyond the search string - return 0
986 lda 1,s ; get length of target string
987 beq L87D6 ; brif targetstring is NULL - match will be immediate
988 ldb 6,s ; get start position
989 decb ; zero-base it
990 abx ; now X points to the start position for the search
991 L87BE leay ,x ; point to start of search
992 ldu 2,s ; get target string pointer
993 ldb 1,s ; get targetlength
994 lda ,s ; get length of serach
995 suba 6,s ; see how much is left in searh
996 inca ; add one for "inclusivity"
997 cmpa 1,s ; do we have less than the target string?
998 blo L87D9 ; brif so - we obviously won't match
999 L87CD lda ,x+ ; compare a byte
1000 cmpa ,u+
1001 bne L87DF ; brif no match
1002 decb ; compared all of target?
1003 bne L87CD ; brif not
1004 L87D6 ldb 6,s ; get position where we matched
1005 skip1
1006 L87D9 clrb ; flag no match
1007 leas 7,s ; clean up stack
1008 jmp LB4F3 ; return unsigned B
1009 L87DF inc 6,s ; bump start position
1010 leax 1,y ; move starting pointer
1011 bra L87BE ; see if we match now
1012 ; Number parsing handler
1013 XVEC19 cmpa #'& ; do we have & (hex or octal)?
1014 bne L8845 ; brif not
1015 leas 2,s ; we won't return to the original invoker
1016 L87EB clr FPA0+2 ; clear bottom of FPA0 for 16 bit value
1017 clr FPA0+3
1018 ldx #FPA0+2 ; point to accumulator
1019 jsr GETNCH ; eat the &
1020 cmpa #'O ; octal?
1021 beq L880A ; brif so
1022 cmpa #'H ; hex?
1023 beq L881F ; brif so
1024 jsr GETCCH ; reset flags on input
1025 bra L880C ; go process octal (default)
1026 L8800 cmpa #'8 ; is it a valid octal character?
1027 lbhi LB277 ; brif not (BUG: should be LBHS or above be #'7)
1028 ldb #3 ; base 8 multiplier
1029 bsr L8834 ; add digit to accumulator
1030 L880A jsr GETNCH ; get input character
1031 L880C bcs L8800 ; brif numeric
1032 L880E clr FPA0 ; clear upper bytes of FPA0
1033 clr FPA0+1
1034 clr VALTYP ; result is numeric
1035 clr FPSBYT ; clear out any extra precision
1036 clr FP0SGN ; make it positive
1037 ldb #0xa0 ; exponent for integer aligned to right of FPA0
1038 stb FP0EXP
1039 jmp LBA1C ; go normalize the result and return
1040 L881F jsr GETNCH ; get input character
1041 bcs L882E ; brif digit
1042 jsr LB3A2 ; set carry if not alpha
1043 L8826 bcs L880E ; brif not alpha
1044 cmpa #'G ; is it valid HEX digit?
1045 bhs L880E ; brif not
1046 suba #7 ; normalize A-F to be just above 0-9
1047 L882E ldb #4 ; four bits per digit
1048 bsr L8834 ; add digit to accumlator
1049 bra L881F ; process another digit
1050 L8834 asl 1,x ; shift accumulator one bit left
1051 rol ,x
1052 lbcs LBA92 ; brif too big - overflow
1053 decb ; done enough bit shifts?
1054 bne L8834 ; brif not
1055 L883F suba #'0 ; remove ASCII bias
1056 adda 1,x ; merge digit into accumlator (this cannot cause carry)
1057 sta 1,x
1058 L8845 rts
1059 ; Expression evaluation handler
1060 XVEC15 puls u ; get back return address
1061 clr VALTYP ; set result to numeric
1062 ldx CHARAD ; save input pointer
1063 jsr GETNCH ; get the input character
1064 cmpa #'& ; HEX or OCTAL?
1065 beq L87EB ; brif so
1066 cmpa #0xcc ; FN?
1067 beq L88B4 ; brif so - do "FNx()"
1068 cmpa #0xff ; function token?
1069 bne L8862 ; brif not
1070 jsr GETNCH ; get function token value
1071 cmpa #0x83 ; USR?
1072 lbeq L892C ; brif so - short circuit Color Basic's USR handler
1073 L8862 stx CHARAD ; restore input pointer
1074 jmp ,u ; return to mainline code
1075 L8866 ldx CURLIN ; are we in immediate mode?
1076 leax 1,x
1077 bne L8845 ; brif not - we're good
1078 ldb #2*11 ; code for illegal direct statement
1079 L886E jmp LAC46 ; raise error
1080 ; DEF command (DEF FN, DEF USR)
1081 DEF ldx [CHARAD] ; get two input characters
1082 cmpx #0xff83 ; USR?
1083 lbeq L890F ; brif so - do DEF USR
1084 bsr L88A1 ; get descriptor address for FN variable
1085 bsr L8866 ; disallow DEF FN in immediate mode
1086 jsr LB26A ; make sure we have (
1087 ldb #0x80 ; disallow arrays as arguments
1088 stb ARYDIS
1089 jsr LB357 ; evaluate variable
1090 bsr L88B1 ; make sure it's numeric
1091 jsr LB267 ; make sure we have )
1092 ldb #0xb3 ; make sure we have =
1093 jsr LB26F
1094 ldx V4B ; get variable descriptor address
1095 ldd CHARAD ; get input pointer
1096 std ,x ; save address of the actual function code in variable descriptor
1097 ldd VARPTR ; get descriptor address of argument
1098 std 2,x ; save argument descriptor address
1099 jmp DATA ; move to the end of this statement
1100 L88A1 ldb #0xcc ; make sure we have FN
1101 jsr LB26F
1102 ldb #0x80 ; disable array lookup
1103 stb ARYDIS
1104 ora #0x80 ; set bit 7 of first character (to indicate FN variable)
1105 jsr LB35C ; find the variable
1106 stx V4B ; save descriptor pointer
1107 L88B1 jmp LB143 ; make sure we have a numeric variable
1108 ; Evaluate an FN call
1109 L88B4 bsr L88A1 ; parse the FNx bit and get the descriptor
1110 pshs x ; save descriptor
1111 jsr LB262 ; evaluate parameter
1112 bsr L88B1 ; make sure it's a number
1113 puls u ; get FN descriptor
1114 ldb #2*25 ; code for undefined function
1115 ldx 2,u ; point to argument variable descriptor
1116 beq L886E ; brif nothing doing there (if it was just created, this will be NULL)
1117 ldy CHARAD ; save current input pointer
1118 ldu ,u ; point to start of FN definition
1119 stu CHARAD ; put input pointer there
1120 lda 4,x ; save original value of argument and save it with current input, and variable pointers
1121 pshs a
1122 ldd ,x
1123 ldu 2,x
1124 pshs u,y,x,d
1125 jsr LBC35 ; set argument variable to the argument
1126 L88D9 jsr LB141 ; go evaluate the FN expression
1127 puls d,x,y,u ; get back variable pointers, input pointer, and original variable value
1128 std ,x
1129 stu 2,x
1130 puls a
1131 sta 4,x
1132 jsr GETCCH ; test end of FN formula
1133 lbne LB277 ; brif not end of statement - problem with the function
1134 sty CHARAD ; restore input pointer
1135 L88EF rts
1136 ; Error handler
1137 XVEC17 cmpb #2*25 ; is it a valid Extended Basic error code?
1138 blo L88EF ; brif not - return to mainline
1139 jsr LA7E9 ; turn off tape
1140 jsr LA974 ; turn off sound
1141 jsr LAD33 ; clean up stack and other bits
1142 clr DEVNUM ; reset output to screen
1143 jsr LB95C ; do a newline if needed
1144 jsr LB9AF ; do a ?
1145 ldx #L890B-25*2 ; point to error message table
1146 jmp LAC60 ; go display error message
1147 ; Extended Basic error codes. Yes, NE is defined here even though it is only actually documented in the
1148 ; Disk Basic documentation. It is here for the use of DLOAD.
1149 L890B fcc 'UF' ; 25 undefined function call
1150 fcc 'NE' ; 26 File not found
1151 ; DEF USR
1152 L890F jsr GETNCH ; eat the USR token
1153 bsr L891C ; get pointer to USR call
1154 pshs x ; save FN exec address location
1155 bsr L8944 ; calculate execution address
1156 puls u ; get FN address pointer
1157 stx ,u ; save new address
1158 rts
1159 L891C clrb ; default routine number is 0
1160 jsr GETNCH ; fetch the call number
1161 bcc L8927 ; brif not a number
1162 suba #'0 ; remove ASCII bias
1163 tfr a,b ; save it in the right place
1164 jsr GETNCH ; eat the call number
1165 L8927 ldx USRADR ; get start address of USR jump table
1166 aslb ; two bytes per address
1167 abx ; now X points to the right entry
1168 rts
1169 ; Evaluate a USR call
1170 L892C bsr L891C ; find the correct routine address location
1171 ldx ,x ; get routine address
1172 pshs x ; save it
1173 jsr LB262 ; evaluate argument
1174 ldx #FP0EXP ; point to FPA0 (argument value)
1175 lda VALTYP ; is it string?
1176 beq L8943 ; brif not
1177 jsr LB657 ; fetch string details (removes it from the string stack)
1178 ldx FPA0+2 ; get string descriptor pointer
1179 lda VALTYP ; set flags for the value type
1180 L8943 rts ; call the routine and return to mainline code
1181 L8944 ldb #0xb3 ; check for "="
1182 jsr LB26F
1183 jmp LB73D ; evaluate integer expression to X and return
1184 ; Extended Basic IRQ handler
1185 XIRQSV lda PIA0+3 ; is it VSYNC interrupt?
1186 bmi L8952 ; brif so
1187 rti ; really should clear the HSYNC interrupt here
1188 L8952 lda PIA0+2 ; clear VSYNC interrupt
1189 ldx TIMVAL ; increment the TIMER value
1190 leax 1,x
1191 stx TIMVAL
1192 jmp L9C3E ; check for other stuff
1193 ; TIMER=
1194 L8960 jsr GETNCH ; eat the TIMER token
1195 bsr L8944 ; evaluate =nnnn to X
1196 stx TIMVAL ; set the timer
1197 rts
1198 ; TIMER function
1199 TIMER ldx TIMVAL ; get timer value
1200 stx FPA0+2 ; set it in FPA0
1201 jmp L880E ; return as positive 16 bit value
1202 ; DEL command
1203 DEL lbeq LB44A ; raise error if no argument (probably to avoid accidentally deleting line 0)
1204 jsr LAF67 ; parse line number
1205 jsr LAD01 ; find line
1206 stx VD3 ; save address of line
1207 jsr GETCCH ; is there something more?
1208 beq L8990 ; brif not
1209 cmpa #0xac ; dash?
1210 bne L89BF ; brif not - error out
1211 jsr GETNCH ; each the -
1212 beq L898C ; brif no ending line - use default line number
1213 bsr L89AE ; parse second line number and save in BINVAL
1214 bra L8990 ; do the deletion
1215 L898C lda #0xff ; set to maximum line number
1216 sta BINVAL
1217 L8990 ldu VD3 ; point end to start
1218 skip2
1219 L8993 ldu ,u ; point to start of next line
1220 ldd ,u ; check for end of program
1221 beq L899F ; brif end of program
1222 ldd 2,u ; get line number
1223 subd BINVAL ; is it in range?
1224 bls L8993 ; brif so
1225 L899F ldx VD3 ; get starting line address
1226 bsr L89B8 ; close up gap
1227 jsr LAD21 ; reset input pointer and erase variables
1228 ldx VD3 ; get start of program after the deletion
1229 jsr LACF1 ; recompute netl ine pointers
1230 jmp LAC73 ; return to immediate mode
1231 L89AE jsr LAF67 ; parse a line number
1232 jmp LA5C7 ; make sure there's nothing more
1233 L89B4 lda ,u+ ; copy a byte
1234 sta ,x+
1235 L89B8 cmpu VARTAB ; end of program?
1236 bne L89B4 ; brif not
1237 stx VARTAB ; save new start of variables/end of program
1238 L89BF rts
1239 ; LINE INPUT
1240 L89C0 jsr L8866 ; raise error if in immediate mode
1241 jsr GETNCH ; eat the "INPUT" token
1242 cmpa #'# ; device number?
1243 bne L89D2 ; brif not
1244 jsr LA5A5 ; parse device number
1245 jsr LA3ED ; make sure it's valid for input
1246 jsr SYNCOMMA ; make sure there's a comma after the device number
1247 L89D2 cmpa #'" ; is there a prompt?
1248 bne L89E1 ; brif not
1249 jsr LB244 ; parse the string
1250 ldb #'; ; make sure there's a semicolon after the prompt
1251 jsr LB26F
1252 jsr LB99F ; go actually display the prompt
1253 L89E1 leas -2,s ; make a hole on the stack (so number of return adddresses is right)
1254 jsr LB035 ; read an input line from current device
1255 leas 2,s ; clean up stack
1256 clr DEVNUM ; reset to screen/keyboard
1257 jsr LB357 ; parse a variable
1258 stx VARDES ; save pointer to it
1259 jsr LB146 ; make sure it's a string
1260 ldx #LINBUF ; point to input buffer
1261 clra ; make sure we terminate on NUL only
1262 jsr LB51A ; parse string and store it in string space
1263 jmp LAFA4 ; go assign the string to its final resting place
1264 ; RENUM command
1265 L89FC jsr LAF67 ; read a line number
1266 ldx BINVAL ; get value
1267 rts
1268 L8A02 ldx VD1 ; get current old number being renumbered
1269 L8A04 stx BINVAL ; save number being searched for
1270 jmp LAD01 ; go find line number
1271 RENUM jsr LAD26 ; erase variables
1272 ldd #10 ; default line number interval and start
1273 std VD5 ; set starting line number
1274 std VCF ; set number interval
1275 clrb ; now D is 0
1276 std VD1 ; save default start for renumbering
1277 jsr GETCCH ; are there any arguments
1278 bcc L8A20 ; brif not numeric
1279 bsr L89FC ; fetch line number
1280 stx VD5 ; save line beginning number
1281 jsr GETCCH ; get input character
1282 L8A20 beq L8A3D ; brif end of line
1283 jsr SYNCOMMA ; make sure we have a comma
1284 bcc L8A2D ; brif next isn't numeric
1285 bsr L89FC ; fetch starting line number
1286 stx VD1 ; save the number where we start working
1287 jsr GETCCH ; fetch input character
1288 L8A2D beq L8A3D ; brif end of line
1289 jsr SYNCOMMA ; make sure we have a comma
1290 bcc L8A3A ; brif we don't have a number
1291 bsr L89FC ; parse the number
1292 stx VCF ; save interval
1293 beq L8A83 ; brif we ave a zero interval
1294 L8A3A jsr LA5C7 ; raise error if more stuff
1295 L8A3D bsr L8A02 ; get address of old number to process
1296 stx VD3 ; save address
1297 ldx VD5 ; get the next renumbered line to use
1298 bsr L8A04 ; find that line
1299 cmpx VD3 ; is it before the previous one?
1300 blo L8A83 ; brif so - raise error
1301 bsr L8A67 ; make sure renumbered line numbers will be in range
1302 jsr L8ADD ; convert line numbers to "expanded" binary
1303 jsr LACEF ; recalculate next line pointers
1304 bsr L8A02 ; get address of first line to renumber
1305 stx VD3 ; save it
1306 bsr L8A91 ; make sure line numbers exist
1307 bsr L8A68 ; renumber the actual lines
1308 bsr L8A91 ; update line numbers in program text
1309 jsr L8B7B ; convert packed binary line numbers to text
1310 jsr LAD26 ; erase variables, reset stack, etc.
1311 jsr LACEF ; recalculate next line pointers
1312 jmp LAC73 ; bounce back to immediate mode
1313 L8A67 skip1lda ; set line number flag to nonzero (skip next instruction)
1314 L8A68 clra ; set line number flag to zero (insert new numbers)
1315 sta VD8 ; save line number flag
1316 ldx VD3 ; get address of line being renumbered
1317 ldd VD5 ; get the current renumbering number
1318 bsr L8A86 ; return if end of program
1319 L8A71 tst VD8 ; test line number flag
1320 bne L8A77 ; brif not adding new numbers
1321 std 2,x ; set new number
1322 L8A77 ldx ,x ; point to next line
1323 bsr L8A86 ; return if end of program
1324 addd VCF ; add interval to current number
1325 bcs L8A83 ; brif we overflowed - bad line number
1326 cmpa #MAXLIN ; maximum legal number?
1327 blo L8A71 ; brif so - do another
1328 L8A83 jmp LB44A ; raise FC error
1329 L8A86 pshs d ; save D (we're going to clobber it)
1330 ldd ,x ; get next line pointer
1331 puls d ; unclobber D
1332 bne L8A90 ; brif not end of program
1333 leas 2,s ; return to caller's caller
1334 L8A90 rts
1335 L8A91 ldx TXTTAB ; get start of program
1336 leax -1,x ; move pointer back one (compensate for leax 1,x below)
1337 L8A95 leax 1,x ; move to next line
1338 bsr L8A86 ; return if end of program
1339 L8A99 leax 3,x ; move past next line address and line number, go one before line
1340 L8A9B leax 1,x ; move to next character
1341 lda ,x ; check input character
1342 beq L8A95 ; brif end of line
1343 stx TEMPTR ; save current pointer
1344 deca ; is it start of packed numeric line number?
1345 beq L8AB2 ; brif so
1346 deca ; does line exist?
1347 beq L8AD3 ; brif line number exists
1348 deca ; not part of something to process?
1349 bne L8A9B ; brif so
1350 L8AAC lda #3 ; set 1st byte to 3 to indicate line number not existing
1351 sta ,x+
1352 bra L8A99 ; go process another
1353 L8AB2 ldd 1,x ; get MSB of line number
1354 dec 2,x ; is MS byte zero?
1355 beq L8AB9 ; brif not
1356 clra ; set MS byte to 0
1357 L8AB9 ldb 3,x ; get LSB of line number
1358 dec 4,x ; is it zero?
1359 beq L8AC0 ; brif not
1360 clrb ; clear byte
1361 L8AC0 std 1,x ; save binary number
1362 std BINVAL ; save trial number
1363 jsr LAD01 ; find the line number
1364 L8AC7 ldx TEMPTR ; get start of packed line
1365 bcs L8AAC ; brif line number not found
1366 ldd V47 ; get address of line number
1367 inc ,x+ ; bump first byte to 2 (exists if checking) or 1 if inserting
1368 std ,x ; save address of correct number
1369 bra L8A99 ; go process more
1370 L8AD3 clr ,x ; clear carry and first byte
1371 ldx 1,x ; point to address of correct line
1372 ldx 2,x ; get correct line number
1373 stx V47 ; save it
1374 bra L8AC7 ; insert into line
1375 L8ADD ldx TXTTAB ; get beginning of program
1376 bra L8AE5
1377 L8AE1 ldx CHARAD ; get input pointer
1378 leax 1,x ; move it forward
1379 L8AE5 bsr L8A86 ; return if end of program
1380 leax 2,x ; move past line address
1381 L8AE9 leax 1,x ; move forward
1382 L8AEB stx CHARAD ; save input pointer
1383 L8AED jsr GETNCH ; get an input character
1384 L8AEF tsta ; is it actual 0?
1385 beq L8AE1 ; brif end of line
1386 bpl L8AED ; brif not a token
1387 ldx CHARAD ; get input pointer
1388 cmpa #0xff ; function?
1389 beq L8AE9 ; brif so - ignore it (and following byte)
1390 jsr RVEC22 ; do the RAM hook thing
1391 cmpa #0xa7 ; THEN?
1392 beq L8B13 ; brif so
1393 cmpa #0x84 ; ELSE?
1394 beq L8B13 ; brif so
1395 cmpa #0x81 ; GO(TO|SUB)?
1396 bne L8AED ; brif not - we don't have a line number
1397 jsr GETNCH ; get TO/SUB
1398 cmpa #0xa5 ; GOTO?
1399 beq L8B13 ; brif so
1400 cmpa #0xa6 ; GOSUB?
1401 bne L8AEB ; brif not
1402 L8B13 jsr GETNCH ; fetch character after token
1403 bcs L8B1B ; brif numeric (line number)
1404 L8B17 jsr GETCCH ; set flags on input character
1405 bra L8AEF ; keep checking for line numbers
1406 L8B1B ldx CHARAD ; get input pointer
1407 pshs x ; save it
1408 jsr LAF67 ; parse line number
1409 ldx CHARAD ; get input pointer after line
1410 L8B24 lda ,-x ; get character before pointer
1411 jsr L90AA ; set C if numeric
1412 bcs L8B24 ; brif not numeric
1413 leax 1,x ; move pointer up
1414 tfr x,d ; calculate size of line number
1415 subb 1,s
1416 subb #5 ; make sure at least 5 bytes
1417 beq L8B55 ; brif exactly 5 bytes - no change
1418 blo L8B41 ; brif less than 5 bytes
1419 leau ,x ; move remainder of program backward
1420 negb ; negate extra number of bytes (to subtract from X)
1421 leax b,x ; now X is the correct position to move program to
1422 jsr L89B8 ; shift program backward
1423 bra L8B55
1424 L8B41 stx V47 ; save end of line number space (end of copy)
1425 ldx VARTAB ; get end of program
1426 stx V43 ; set source pointer
1427 negb ; get positive difference
1428 leax b,x ; now X is the top of the destination block
1429 stx V41 ; set copy destination
1430 stx VARTAB ; save new end of program
1431 jsr LAC1E ; make sure enough room and make a hole in the program
1432 ldx V45 ; get end address of destination block
1433 stx CHARAD ; set input there
1434 L8B55 puls x ; get starting address of the line number
1435 lda #1 ; set "new number" flag
1436 sta ,x
1437 sta 2,x
1438 sta 4,x
1439 ldb BINVAL ; get MS byte of line number
1440 bne L8B67 ; brif it is not zero
1441 ldb #1 ; set to 1 if MSB is 0
1442 inc 2,x ; flag MSB as 0
1443 L8B67 stb 1,x ; set MSB of line number
1444 ldb BINVAL+1 ; get LSB of number
1445 bne L8B71 ; brif nonzero
1446 ldb #1 ; set to 1 if LSB is 0
1447 inc 4,x ; flag LSB as 0
1448 L8B71 stb 3,x ; save LSB of line number
1449 jsr GETCCH ; get input character
1450 cmpa #', ; multiple line numbers? (ON GOTO, ON GOSUB)
1451 beq L8B13 ; brif so - process another
1452 bra L8B17 ; go look for more line numbers
1453 L8B7B ldx TXTTAB ; point to start of program
1454 leax -1,x ; move back (compensate for inc below)
1455 L8B7F leax 1,x ; move forward
1456 ldd 2,x ; get this line number
1457 std CURLIN ; save it (for error message)
1458 jsr L8A86 ; return if end of program
1459 leax 3,x ; skip address and line number, stay one before line text
1460 L8B8A leax 1,x ; move to next character
1461 L8B8C lda ,x ; get input character
1462 beq L8B7F ; brif end of line
1463 deca ; valid line new line number?
1464 beq L8BAE ; brif so
1465 suba #2 ; undefined line?
1466 bne L8B8A ; brif not
1467 pshs x ; save line number pointer
1468 ldx #L8BD9-1 ; show UL message
1469 jsr STRINOUT
1470 ldx ,s ; get input pointer
1471 ldd 1,x ; get undefined line number
1472 jsr LBDCC ; display line number
1473 jsr LBDC5 ; print out "IN XXXX"
1474 jsr LB958 ; do a newline
1475 puls x ; get input pointer back
1476 L8BAE pshs x ; save input pointer
1477 ldd 1,x ; get binary value of line number
1478 std FPA0+2 ; save it in FPA0
1479 jsr L880E ; adjust FPA0 as integer
1480 jsr LBDD9 ; convert to text string
1481 puls u ; get previous input pointer address
1482 ldb #5 ; each expanded line uses 5 bytes
1483 L8BBE leax 1,x ; move pointer forward (in string number) past sign
1484 lda ,x ; do we have a digit?
1485 beq L8BC9 ; brif not - end of number
1486 decb ; mark a byte consumed
1487 sta ,u+ ; put digit in program
1488 bra L8BBE ; copy another digit
1489 L8BC9 leax ,u ; point to address at end of text number
1490 tstb ; did number fill whole space?
1491 beq L8B8C ; brif so - move on
1492 leay ,u ; save end of number pointer
1493 leau b,u ; point to the end of the original expanded number
1494 jsr L89B8 ; close up gap in program
1495 leax ,y ; get end of line number pointer back
1496 bra L8B8C ; go process more
1497 L8BD9 fcn 'UL '
1498 ; HEX$ function
1499 HEXDOL jsr LB740 ; convert argument to positive integer
1500 ldx #STRBUF+2 ; point to string buffer
1501 ldb #4 ; convert 4 nibbles
1502 L8BE5 pshs b ; save nibble counter
1503 clrb ; clear digit accumulator
1504 lda #4 ; do 4 shifts
1505 L8BEA asl FPA0+3 ; shift a bit off the left of the value into low bits of B
1506 rol FPA0+2
1507 rolb
1508 deca ; done all shifts?
1509 bne L8BEA ; brif not
1510 tstb ; do we have a nonzero digit?
1511 bne L8BFF ; brif so
1512 lda ,s ; is it last digit?
1513 deca
1514 beq L8BFF ; brif so - keep the 0
1515 cmpx #STRBUF+2 ; is it a middle zero?
1516 beq L8C0B ; brif not
1517 L8BFF addb #'0 ; add ASCII bias
1518 cmpb #'9 ; above 9?
1519 bls L8C07 ; brif not
1520 addb #7 ; adjust into alpha range
1521 L8C07 stb ,x+ ; save digit in output
1522 clr ,x ; make sure we have a NUL term
1523 L8C0B puls b ; get back nibble counter
1524 decb ; done all?
1525 bne L8BE5 ; brif not
1526 leas 2,s ; don't return mainline (we're returning a string)
1527 ldx #STRBUF+1 ; point to start of converted number
1528 jmp LB518 ; save string in string space, etc., and return it
1529 ; DLOAD command
1530 DLOAD jsr LA429 ; close files
1531 L8C1B jsr GETCCH ; get back input character
1532 suba #'M ; is it DLOADM?
1533 pshs a ; save DLOADM flag
1534 bne L8C25 ; brif DLOAD
1535 jsr GETNCH ; eat the "M"
1536 L8C25 jsr LA578 ; parse the file name
1537 jsr GETCCH ; get character after file name
1538 beq L8C44 ; brif end of line
1539 jsr SYNCOMMA ; make sure we have a comma
1540 cmpa #', ; do we have 2 commas?
1541 beq L8C44 ; brif so - use default baud rate
1542 jsr EVALEXPB ; evaluate baud rate
1543 L8C36 lda #44*4 ; delay for 300 baud
1544 tstb ; was argument 0?
1545 beq L8C42 ; brif so - 300 baud
1546 lda #44 ; constant for 1200 baud
1547 decb ; was it 1?
1548 lbne LB44A ; raise error if not
1549 L8C42 sta DLBAUD ; save baud rate constant
1550 L8C44 jsr L8CD0 ; transmit file name and read in file status
1551 pshs a ; save register
1552 lda #-3 ; set input to DLOAD
1553 sta DEVNUM
1554 puls a ; restore register
1555 tst ,s+ ; is it DLOADM?
1556 beq L8C85 ; brif so
1557 jsr LA5C7 ; check for end of line - error if not
1558 tstb ; ASCII?
1559 beq L8C5F ; brif not - do error
1560 jsr LAD19 ; clear out program
1561 jmp LAC7C ; go read program
1562 L8C5F jmp LA616 ; raise bad file mode
1563 ; CLOADM patch for Extended Basic
1564 L8C62 jsr GETNCH ; get character after CLOAD
1565 cmpa #'M ; CLOADM?
1566 lbne CLOAD ; brif not - Color Basic's CLOAD can handle it
1567 clr FILSTA ; close tape file
1568 jsr GETNCH ; eat the "M"
1569 jsr LA578 ; parse file name
1570 jsr LA648 ; find the file
1571 tst CASBUF+10 ; is it a chunked file?
1572 lbeq LA505 ; brif not - Color Basic's CLOADM can handle it
1573 ldu CASBUF+8 ; get file type and ASCII flag
1574 dec DEVNUM ; set source device to tape
1575 jsr LA635 ; go read the first block
1576 tfr u,d ; put type and ASCII flag somewhere more useful
1577 ; NOTE: DLOADM comes here to do the final processing
1578 L8C85 subd #0x200 ; is it binary and "machine language"?
1579 bne L8C5F ; brif not - raise an error
1580 ldx ZERO ; default load offset
1581 jsr GETCCH ; is there any offset?
1582 beq L8C96 ; brif not
1583 jsr SYNCOMMA ; make sure there's a comma
1584 jsr LB73D ; evaluate offset in X
1585 L8C96 stx VD3 ; save offset
1586 jsr LA5C7 ; raise error if more stuff follows
1587 L8C9B bsr L8CC6 ; get type of "amble"
1588 pshs a ; save it
1589 bsr L8CBF ; read in block length
1590 tfr d,y ; save it
1591 bsr L8CBF ; read in load address
1592 addd VD3 ; add in offset
1593 std EXECJP ; save it as the execution address
1594 tfr d,x ; put load address in a pointer
1595 lda ,s+ ; get "amble" type
1596 lbne LA42D ; brif postamble - close file
1597 L8CB1 bsr L8CC6 ; read a data byte
1598 sta ,x ; save in memory
1599 cmpa ,x+ ; did it actually save?
1600 bne L8CCD ; brif not RAM - raise error
1601 leay -1,y ; done yet?
1602 bne L8CB1 ; brif not
1603 bra L8C9B ; look for another "amble"
1604 L8CBF bsr L8CC1 ; read a character to B
1605 L8CC1 bsr L8CC6 ; read character to A
1606 exg a,b ; swap character with previously read one
1607 L8CC5 rts
1608 L8CC6 jsr LA176 ; read a character from input
1609 tst CINBFL ; EOF?
1610 beq L8CC5 ; brif not
1611 L8CCD jmp LA619 ; raise I/O error if EOF
1612 L8CD0 bsr L8D14 ; transmit file name
1613 pshs b,a ; save file status
1614 inca ; was file found?
1615 beq L8CDD ; brif not
1616 ldu ZERO ; zero U - first block
1617 bsr L8CE4 ; read block
1618 puls a,b,pc ; restore status and return
1619 L8CDD ldb #2*26 ; code for NE error
1620 jmp LAC46 ; raise error
1621 L8CE2 ldu CBUFAD ; get block number
1622 L8CE4 leax 1,u ; bump block number
1623 stx CBUFAD ; save new block number
1624 ldx #CASBUF ; use cassette buffer
1625 jsr L8D7C ; read a block
1626 jmp LA644 ; reset input buffer pointers
1627 ; Generic input handler for Extended Basic
1628 XVEC4 lda DEVNUM ; get device number
1629 cmpa #-3 ; DLOAD?
1630 bne L8D01 ; brif not
1631 leas 2,s ; don't return to mainline code
1632 clr CINBFL ; reset EOF flag to not EOF
1633 tst CINCTR ; anything available?
1634 bne L8D02 ; brif so - fetch one
1635 com CINBFL ; flag EOF
1636 L8D01 rts
1637 L8D02 pshs u,y,x,b ; save registers
1638 ldx CINPTR ; get buffer pointer
1639 lda ,x+ ; get character from buffer
1640 pshs a ; save it for return
1641 stx CINPTR ; save new input pointer
1642 dec CINCTR ; account for byte removed from buffer
1643 bne L8D12 ; brif buffer not empty
1644 bsr L8CE2 ; go read a block
1645 L8D12 puls a,b,x,y,u,pc ; restore registers, return value, and return
1646 L8D14 clra ; clear attempt counter
1647 pshs x,b,a ; make a hole for variables
1648 leay ,s ; set up frame pointer
1649 bra L8D1D ; go read block
1650 L8D1B bsr L8D48 ; bump attempt counter
1651 L8D1D lda #0x8a ; send file request control code
1652 bsr L8D58
1653 bne L8D1B ; brif no echo or error
1654 ldx #CFNBUF+1 ; point to file name
1655 L8D26 lda ,x+ ; get file name characater
1656 jsr L8E04 ; send it
1657 cmpx #CFNBUF+9 ; end of file name?
1658 bne L8D26 ; brif not
1659 bsr L8D62 ; output check byte and look for response
1660 bne L8D1B ; transmit name again if not ack
1661 bsr L8D72 ; get file type (0xff is not found)
1662 bne L8D1B ; brif error
1663 sta 2,y ; save file type
1664 bsr L8D72 ; read ASCII flag
1665 bne L8D1B ; brif error
1666 sta 3,y ; save ASCII flag
1667 bsr L8D6B ; read check byte
1668 bne L8D1B ; brif error
1669 leas 2,s ; lose attempt counter and check byte
1670 puls a,b,pc ; return file type and ascii flag
1671 L8D48 inc ,y ; bump attempt counter
1672 lda ,y ; get new count
1673 cmpa #5 ; done 5 times?
1674 blo L8D6A ; brif not
1675 lda #0xbc ; send abort code
1676 jsr L8E0C
1677 jmp LA619 ; raise an I/O error
1678 L8D58 pshs a ; save compare character
1679 bsr L8DB8 ; send character
1680 bne L8D60 ; brif read error
1681 cmpa ,s ; does it match? (set Z if good)
1682 L8D60 puls a,pc ; restore character and return
1683 L8D62 lda 1,y ; get XOR check byte
1684 bsr L8DB8 ; send it and read
1685 bne L8D6A ; brif read error
1686 cmpa #0xc8 ; is it ack? (set Z if so)
1687 L8D6A rts
1688 L8D6B bsr L8D72 ; read character from rs232
1689 bne L8D6A ; brif error
1690 lda 1,y ; get check byte
1691 rts
1692 L8D72 bsr L8DBC ; read a character from rs232
1693 pshs a,cc ; save result (and flags)
1694 eora 1,y ; accumulate xor checksum
1695 sta 1,y
1696 puls cc,a,pc ; restore byte, flags, and return
1697 L8D7C clra ; reset attempt counter
1698 pshs u,y,x,b,a ; make a stack frame
1699 asl 7,s ; split block number into two 7 bit chuncks
1700 rol 6,s
1701 lsr 7,s
1702 leay ,s ; set up frame pointer
1703 bra L8D8B
1704 L8D89 bsr L8D48 ; bump attempt counter
1705 L8D8B lda #0x97 ; send block request code
1706 bsr L8D58
1707 bne L8D89 ; brif error
1708 lda 6,y ; send out block number (high bits first)
1709 bsr L8E04
1710 lda 7,y
1711 bsr L8E04
1712 bsr L8D62 ; send check byte and get ack
1713 bne L8D89 ; brif error
1714 bsr L8D72 ; read block size
1715 bne L8D89 ; brif read error
1716 sta 4,y ; save character count
1717 ldx 2,y ; get buffer pointer
1718 ldb #128 ; length of data block
1719 L8DA7 bsr L8D72 ; read a data byte
1720 bne L8D89 ; brif error
1721 sta ,x+ ; save byte in buffer
1722 decb ; done a whole block?
1723 bne L8DA7 ; brif not
1724 bsr L8D6B ; read check byte
1725 bne L8D89 ; brif error
1726 leas 4,s ; lose attempt counter, check byte, and buffer pointer
1727 puls a,b,x,pc ; return with character count in A, clean rest of stack
1728 L8DB8 clr 1,y ; clear check byte
1729 bsr L8E0C ; output character
1730 L8DBC clra ; clear attempt counter
1731 pshs x,b,cc ; save registers and interrupt status
1732 orcc #0x50 ; disable interrupts
1733 lda TIMOUT ; get timout delay (variable)
1734 ldx ZERO ; get constant timeout value
1735 L8DC5 bsr L8DE6 ; get RS232 status
1736 bcc L8DC5 ; brif "space" - waiting for "mark"
1737 L8DC9 bsr L8DE6 ; get RS232 status
1738 bcs L8DC9 ; brif "mark" - waiting for "space" (start bit)
1739 bsr L8DF9 ; delay for half of bit time
1740 ldb #1 ; set bit probe
1741 pshs b ; save it
1742 clra ; reset data byte
1743 L8DD4 bsr L8DF7 ; wait one bit time
1744 ldb PIA1+2 ; get input bit to carry
1745 rorb
1746 bcc L8DDE ; brif "space" (0)
1747 ora ,s ; merge bit probe in
1748 L8DDE asl ,s ; shift bit probe over
1749 bcc L8DD4 ; brif we haven't done 8 bits
1750 leas 1,s ; remove bit probe
1751 puls cc,b,x,pc ; restore interrupts, registers, and return
1752 L8DE6 ldb PIA1+2 ; get RS232 value
1753 rorb ; put in C
1754 leax 1,x ; bump timeout
1755 bne L8DF6 ; brif nonzero
1756 deca ; did the number of waits expire?
1757 bne L8DF6 ; brif not
1758 leas 2,s ; don't return - we timed out
1759 puls cc,b,x ; restore interrupts and registers
1760 inca ; clear Z (A was zero above)
1761 L8DF6 rts
1762 L8DF7 bsr L8DF9 ; do first half of bit delay then fall through for second
1763 L8DF9 pshs a ; save register
1764 lda DLBAUD ; get baud rate constant
1765 L8DFD brn L8DFD ; do nothing - delay
1766 deca ; time expired?
1767 bne L8DFD ; brif not
1768 puls a,pc ; restore register and return
1769 L8E04 pshs a ; save character to send
1770 eora 1,y ; accumulate chechsum
1771 sta 1,y
1772 puls a ; get character back
1773 L8E0C pshs b,a,cc ; save registers and interrupt status
1774 orcc #0x50 ; disable interrupts
1775 bsr L8DF7 ; do a bit delay
1776 bsr L8DF7 ; do another bit delay
1777 clr PIA1 ; set output to space (start bit)
1778 bsr L8DF7 ; do a bit delay
1779 ldb #1 ; bit probe start at LSB
1780 pshs b ; save bitprobe
1781 L8E1D lda 2,s ; get output byte
1782 anda ,s ; see what our current bit is
1783 beq L8E25 ; brif output is 0
1784 lda #2 ; set output to "marking"
1785 L8E25 sta PIA1 ; send bit
1786 bsr L8DF7 ; do a bit delay
1787 asl ,s ; shift bit probe
1788 bcc L8E1D ; brif not last bit
1789 lda #2 ; set output to marking ("stop" bit)
1790 sta PIA1
1791 leas 1,s ; lose bit probe
1792 puls cc,a,b,pc ; restore registers, interrupts, and return
1793 ; PRINT USING
1794 ; This is a massive block of code for something that has limited utility. It is *almost* flexible enough to
1795 ; be truly useful outside of a narrow range of use cases. Indeed, this comes in at about 1/8 of the total
1796 ; Extended Color Basic ROM.
1797 ;
1798 ; This uses several variables:
1799 ; VD5: pointer to format string descriptor
1800 ; VD7: next print item flag
1801 ; VD8: right digit counter
1802 ; VD9: left digit counter (or length of string argument)
1803 ; VDA: status byte (bits as follows):
1804 ; 6: force comma
1805 ; 5: force leading *
1806 ; 4: floating $
1807 ; 3: pre-sign
1808 ; 2: post-sign
1809 ; 0: scientific notation
1810 L8E37 lda #1 ; set length to use to 1
1811 sta VD9
1812 L8E3B decb ; consume character from format string
1813 jsr L8FD8 ; show error flag if flags set
1814 jsr GETCCH ; get input character
1815 lbeq L8ED8 ; brif end of line - bail
1816 stb VD3 ; save remaining string length
1817 jsr LB156 ; evaluate the argument
1818 jsr LB146 ; error if numeric
1819 ldx FPA0+2 ; get descriptor for argument
1820 stx V4D ; save it for later
1821 ldb VD9 ; get length counter to use
1822 jsr LB6AD ; get B bytes of string space (do a LEFT$)
1823 jsr LB99F ; print the formatted string
1824 ldx FPA0+2 ; get formatted string descriptor
1825 ldb VD9 ; get requested length
1826 subb ,x ; see if we have any left over
1827 L8E5F decb ; have we got the right width?
1828 lbmi L8FB3 ; brif so - go process more
1829 jsr LB9AC ; output a space
1830 bra L8E5F ; go see if we're done yet
1831 L8E69 stb VD3 ; save current format string counter and pointer
1832 stx TEMPTR
1833 lda #2 ; initial spaces count = 2 (for the two %s)
1834 sta VD9 ; save length counter
1835 L8E71 lda ,x ; get character in string
1836 cmpa #'% ; is it the end of the sequence?
1837 beq L8E3B ; brif so - display requested part of the strign
1838 cmpa #0x20 ; space?
1839 bne L8E82 ; brif not
1840 inc VD9 ; bump spaces count
1841 leax 1,x ; move format pointer forward
1842 decb ; consume character
1843 bne L8E71 ; brif not end of format string
1844 L8E82 ldx TEMPTR ; restore format string pointer
1845 ldb VD3 ; get back format string length
1846 lda #'% ; show % as debugging aid
1847 L8E88 jsr L8FD8 ; send error indicator if flags set
1848 jsr PUTCHR ; output character
1849 bra L8EB9 ; go process more format string
1850 ; PRINT extension for USING
1851 XVEC9 cmpa #0xcd ; USING?
1852 beq L8E95 ; brif so
1853 rts ; return to mainline code
1854 ; This is the main entry point for PRINT USING
1855 L8E95 leas 2,s ; don't return to the mainline code
1856 jsr LB158 ; evaluate the format string
1857 jsr LB146 ; error if numeric
1858 ldb #'; ; make sure there's a ; after the string
1859 jsr LB26F
1860 ldx FPA0+2 ; get format string descriptor
1861 stx VD5 ; save it for later
1862 bra L8EAE ; process format string
1863 L8EA8 lda VD7 ; is there a print item?
1864 beq L8EB4 ; brif not
1865 ldx VD5 ; get back format string descriptor
1866 L8EAE clr VD7 ; reset next print item flag
1867 ldb ,x ; get length of format string
1868 bne L8EB7 ; brif string is non-null
1869 L8EB4 jmp LB44A ; raise FC error
1870 L8EB7 ldx 2,x ; point to start of string
1871 L8EB9 clr VDA ; clear status (new item)
1872 L8EBB clr VD9 ; clear left digit counter
1873 lda ,x+ ; get character from format string
1874 cmpa #'! ; ! (use first character of string)?
1875 lbeq L8E37 ; brif so
1876 cmpa #'# ; digit?
1877 beq L8F24 ; brif so - handle numeric
1878 decb ; consume format character
1879 bne L8EE2 ; brif not done
1880 jsr L8FD8 ; show a "+" if any flags set - indicates error at end of string
1881 jsr PUTCHR ; output format string character
1882 L8ED2 jsr GETCCH ; get current input character
1883 bne L8EA8 ; brif not end of statement
1884 lda VD7 ; get next item flag
1885 L8ED8 bne L8EDD ; brif more print items
1886 jsr LB958 ; do newline
1887 L8EDD ldx VD5 ; point to format string descriptor
1888 jmp LB659 ; remove from string stack, etc., if appropriate (and return)
1889 L8EE2 cmpa #'+ ; is it + (pre-sign)?
1890 bne L8EEF ; brif not
1891 jsr L8FD8 ; send a "+" if flags set
1892 lda #8 ; flag for pre-sign
1893 sta VDA ; set flags
1894 bra L8EBB ; go interpret some more stuff
1895 L8EEF cmpa #'. ; decimal?
1896 beq L8F41 ; brif so - numeric
1897 cmpa #'% ; % (show string)?
1898 lbeq L8E69 ; brif so
1899 cmpa ,x ; do we have two identical characters?
1900 L8EFB bne L8E88 ; brif not - invalid format character
1901 cmpa #'$ ; double $?
1902 beq L8F1A ; brif so - floating $
1903 cmpa #'* ; double *?
1904 bne L8EFB ; brif not
1905 lda VDA ; get status byte
1906 ora #0x20 ; enable * padding
1907 sta VDA
1908 cmpb #2 ; is $$ the last two?
1909 blo L8F20 ; brif so
1910 lda 1,x ; is it $ after?
1911 cmpa #'$
1912 bne L8F20 ; brif not
1913 decb ; consume the "$"
1914 leax 1,x
1915 inc VD9 ; add to digit counter * pad + $ counter
1916 L8F1A lda VDA ; indicate floating $
1917 ora #0x10
1918 sta VDA
1919 L8F20 leax 1,x ; consume the second format character
1920 inc VD9 ; add one more left place
1921 L8F24 clr VD8 ; clear right digit counter
1922 L8F26 inc VD9 ; bump left digit counter
1923 decb ; consume character
1924 beq L8F74 ; brif end of string
1925 lda ,x+ ; get next format character
1926 cmpa #'. ; decimal?
1927 beq L8F4F ; brif so
1928 cmpa #'# ; digit?
1929 beq L8F26 ; brif so
1930 cmpa #', ; comma flag?
1931 bne L8F5A ; brif not
1932 lda VDA ; set commas flag
1933 ora #0x40
1934 sta VDA
1935 bra L8F26 ; handle more characters to left of decimal
1936 L8F41 lda ,x ; get character after .
1937 cmpa #'# ; digit?
1938 lbne L8E88 ; brif not - invalid
1939 lda #1 ; set right digit counter to 1 (for the .)
1940 sta VD8
1941 leax 1,x ; consume the .
1942 L8F4F inc VD8 ; add one to right digit counter
1943 decb ; consume character
1944 beq L8F74 ; brif end of format string
1945 lda ,x+ ; get another format character
1946 cmpa #'# ; digit?
1947 beq L8F4F ; brif so
1948 L8F5A cmpa #0x5e ; up arrow?
1949 bne L8F74 ; brif not
1950 cmpa ,x ; two of them?
1951 bne L8F74 ; brif not
1952 cmpa 1,x ; three of them?
1953 bne L8F74 ; brif not
1954 cmpa 2,x ; four of them?
1955 bne L8F74 ; brif not
1956 cmpb #4 ; string actually has the characters?
1957 blo L8F74 ; brif not
1958 subb #4 ; consome them
1959 leax 4,x
1960 inc VDA ; set scientific notation bit
1961 L8F74 leax -1,x ; back up input pointer
1962 inc VD9 ; add one digit for pre-sign force
1963 lda VDA ; is it pre-sign?
1964 bita #8
1965 bne L8F96 ; brif so
1966 dec VD9 ; undo pre-sign adjustment
1967 tstb ; end of string?
1968 beq L8F96 ; brif so
1969 lda ,x ; get next character
1970 suba #'- ; post sign force?
1971 beq L8F8F ; brif so
1972 cmpa #'+-'- ; plus?
1973 bne L8F96 ; brif not
1974 lda #8 ; trailing + is a pre-sign force
1975 L8F8F ora #4 ; add in post sign flag
1976 ora VDA ; merge with flags
1977 sta VDA
1978 decb ; consume character
1979 L8F96 jsr GETCCH ; do we have an argument
1980 lbeq L8ED8 ; brif not
1981 stb VD3 ; save format string length
1982 jsr LB141 ; evluate numeric expression
1983 lda VD9 ; get left digit counter
1984 adda VD8 ; add in right digit counter
1985 cmpa #17 ; is it more than 16 digits + decimal?
1986 lbhi LB44A ; brif so - this is a problem
1987 jsr L8FE5 ; format value according to settings
1988 leax -1,x ; move buffer pointer back
1989 jsr STRINOUT ; display formatted number string
1990 L8FB3 clr VD7 ; reset next print item flag
1991 jsr GETCCH ; get current input character
1992 beq L8FC6 ; brif end of statement
1993 sta VD7 ; set next print flag to nonzero
1994 cmpa #'; ; list separator ;?
1995 beq L8FC4 ; brif so
1996 jsr SYNCOMMA ; require a comma between if not ;
1997 bra L8FC6 ; process next item
1998 L8FC4 jsr GETNCH ; munch the semicolon
1999 L8FC6 ldx VD5 ; get format string descriptor
2000 ldb ,x ; get length of string
2001 subb VD3 ; subtract amount left after last item
2002 ldx 2,x ; point to string address
2003 abx ; move pointer to correct spot
2004 ldb VD3 ; get remaining string length
2005 lbne L8EB9 ; if we have more, interpret from there
2006 jmp L8ED2 ; re-interpret from start if we hit the end
2007 L8FD8 pshs a ; save character
2008 lda #'+ ; "error" flag character
2009 tst VDA ; did we have some flags set?
2010 beq L8FE3 ; brif not
2011 jsr PUTCHR ; output error flag
2012 L8FE3 puls a,pc ; restore character and return
2013 L8FE5 ldu #STRBUF+4 ; point to string buffer
2014 ldb #0x20 ; blank space
2015 lda VDA ; get flags
2016 bita #8 ; pre-sign?
2017 beq L8FF2 ; brif not
2018 ldb #'+ ; plus sign
2019 L8FF2 tst FP0SGN ; get sign of value
2020 bpl L8FFA ; brif positive
2021 clr FP0SGN ; make number positive (for later)
2022 ldb #'- ; negative sign
2023 L8FFA stb ,u+ ; put sign in buffer
2024 ldb #'0 ; put a zero there
2025 stb ,u+
2026 anda #1 ; check scientific notation force
2027 lbne L910D ; brif so
2028 ldx #LBDC0 ; point to FP 1E+9
2029 jsr LBCA0 ; is it less?
2030 bmi L9023 ; brif so
2031 jsr LBDD9 ; convert FP number to string (we're doing scientific notation)
2032 L9011 lda ,x+ ; advance pointer to end of string
2033 bne L9011
2034 L9015 lda ,-x ; make a hole at the start
2035 sta 1,x
2036 cmpx #STRBUF+3 ; done yet?
2037 bne L9015 ; brif not
2038 lda #'% ; put "overflow" flag at start
2039 sta ,x
2040 rts
2041 L9023 lda FP0EXP ; get exponent of value
2042 sta V47 ; save it
2043 beq L902C ; brif value is 0
2044 jsr L91CD ; convert to number with 9 significant figures to left of decimal
2045 L902C lda V47 ; get base 10 exponent offset
2046 lbmi L90B3 ; brif < 100,000,000
2047 nega ; get negative difference
2048 adda VD9 ; add to number of left digits
2049 suba #9 ; account for the 9 we actually have
2050 jsr L90EA ; put leading zeroes in buffer
2051 jsr L9263 ; initialize the decimal point and comma counters
2052 jsr L9202 ; convert FPA0 to decimal ASCII in buffer
2053 lda V47 ; get base 10 exponent
2054 jsr L9281 ; put that many zeroes in buffer, stop at decimal point
2055 lda V47 ; get base 10 exponent
2056 jsr L9249 ; check for decimal
2057 lda VD8 ; get right digit counter
2058 bne L9050 ; brif we want stuff after decimal
2059 leau -1,u ; delete decimal if not needed
2060 L9050 deca ; subtract one place (for decimal)
2061 jsr L90EA ; put zeroes in buffer (trailing)
2062 L9054 jsr L9185 ; insert * padding, floating $, and post-sign
2063 tsta ; was there a post sign?
2064 beq L9060 ; brif not
2065 cmpb #'* ; was first character a *?
2066 beq L9060 ; brif so
2067 stb ,u+ ; store the post sign
2068 L9060 clr ,u ; make srue it's NUL terminated
2069 ldx #STRBUF+3 ; point to start of buffer
2070 L9065 leax 1,x ; move to next character
2071 stx TEMPTR ; save it for later
2072 lda VARPTR+1 ; get address of decimal point
2073 suba TEMPTR+1 ; subtract out actual digits left of decimal
2074 suba VD9 ; subtract out required left digits
2075 beq L90A9 ; brif no padding needed
2076 lda ,x ; get current character
2077 cmpa #0x20 ; space?
2078 beq L9065 ; brif so - advance pointer
2079 cmpa #'* ; *?
2080 beq L9065 ; brif so - advance pointer
2081 clra ; zero on stack is end of data ponter
2082 L907C pshs a ; save character on stack
2083 lda ,x+ ; get next character
2084 cmpa #'- ; minus?
2085 beq L907C ; brif so
2086 cmpa #'+ ; plus?
2087 beq L907C ; brif so
2088 cmpa #'$ ; $?
2089 beq L907C ; brif so
2090 cmpa #'0 ; zero?
2091 bne L909E ; brif not
2092 lda 1,x ; get character after 0
2093 bsr L90AA ; clear carry if number
2094 bcs L909E ; brif not number
2095 L9096 puls a ; get character off stack
2096 sta ,-x ; put it back in string buffer
2097 bne L9096 ; brif not - restore another
2098 bra L9065 ; keep cleaning up buffer
2099 L909E puls a ; get the character on the stack
2100 tsta ; is it NUL?
2101 bne L909E ; brif not
2102 ldx TEMPTR ; get string buffer start pointer
2103 lda #'% ; put error flag in front
2104 sta ,-x
2105 L90A9 rts
2106 L90AA cmpa #'0 ; zero?
2107 blo L90B2 ; brif not
2108 suba #'9+1 ; set C if > "9"
2109 suba #-('9+1)
2110 L90B2 rts
2111 L90B3 lda VD8 ; get right digit counter
2112 beq L90B8 ; brif not right digits
2113 deca ; account for decimal point
2114 L90B8 adda V47 ; add base 10 exponent offset
2115 bmi L90BD ; if >= 0, no shifts are required
2116 clra ; force shift counter to 0
2117 L90BD pshs a ; save shift counter
2118 L90BF bpl L90CB ; brif positive count
2119 pshs a ; save shift counter
2120 jsr LBB82 ; divide FPA0 by 10 (shift 1 digit to the right)
2121 puls a ; get shift counter back
2122 inca ; account for the shift
2123 bra L90BF ; see if we're done yet
2124 L90CB lda V47 ; get base 10 exponent offset
2125 suba ,s+ ; account for adjustment
2126 sta V47 ; save new exponent offset
2127 adda #9 ; account for significant places
2128 bmi L90EE ; brif we don't need zeroes to left
2129 lda VD9 ; get left decimal counter
2130 suba #9 ; account for significant figures
2131 suba V47 ; subtract exponent offset
2132 bsr L90EA ; output leading zeroes
2133 jsr L9263 ; initialize decimal and comma counters
2134 bra L90FF ; process remainder of digits
2135 L90E2 pshs a ; save zero counter
2136 lda #'0 ; insert a 0
2137 sta ,u+
2138 puls a ; get back counter
2139 L90EA deca ; do we need more zeroes?
2140 bpl L90E2 ; brif so
2141 rts
2142 L90EE lda VD9 ; get left digit counter
2143 bsr L90EA ; put that many zeroes in
2144 jsr L924D ; put decimal in buffer
2145 lda #-9 ; figure out filler zeroes
2146 suba V47
2147 bsr L90EA ; output required leader zeroes
2148 clr V45 ; clear decimal pointer counter
2149 clr VD7 ; clear comma counter
2150 L90FF jsr L9202 ; decode FPA0 to decimal string
2151 lda VD8 ; get right digit counter
2152 bne L9108 ; brif there are right digits
2153 ldu VARPTR ; point to decimal location of decimal
2154 L9108 adda V47 ; add base 10 exponent
2155 lbra L9050 ; add in leading astrisks, etc.
2156 L910D lda FP0EXP ; get exponent of FPA0
2157 pshs a ; save it
2158 beq L9116 ; brif 0
2159 jsr L91CD ; convert to number with 9 figures
2160 L9116 lda VD8 ; get right digit counter
2161 beq L911B ; brif no right digits
2162 deca ; account for decimal point
2163 L911B adda VD9 ; get left digit counter
2164 clr STRBUF+3 ; use buffer byte as temporary storage
2165 ldb VDA ; get status flags
2166 andb #4 ; post-sign?
2167 bne L9129 ; brif so
2168 com STRBUF+3 ; flip byte if no post sign
2169 L9129 adda STRBUF+3 ; subtract 1 if no post sign
2170 suba #9 ; account for significant figures
2171 pshs a ; save shift counter
2172 L9130 bpl L913C ; brif no more shifts needed
2173 pshs a ; save counter
2174 jsr LBB82 ; divide by 10 (shift right one)
2175 puls a ; get back counter
2176 inca ; account for the shift
2177 bra L9130 ; see if we need more
2178 L913C lda ,s ; get original shift count
2179 bmi L9141 ; brif shifting happened
2180 clra ; flag for no shifting
2181 L9141 nega ; calculate position of decimal (negate shift count, add left digit and post sign if needed)
2182 adda VD9 ; add left digit counter
2183 inca ; and post sign
2184 adda STRBUF+3
2185 sta V45 ; save decimal counter
2186 clr VD7 ; clear comma counter
2187 jsr L9202 ; convert to decimal string
2188 puls a ; get shift counter
2189 jsr L9281 ; put the needed zeroes in
2190 lda VD8 ; get right digit counter
2191 bne L915A ; brif we want some
2192 leau -1,u ; remove te decimal point
2193 L915A ldb ,s+ ; get original exponent
2194 beq L9167 ; brif it was 0
2195 ldb V47 ; get base 10 exponent
2196 addb #9 ; account for significant figures
2197 subb VD9 ; remove left digit count
2198 subb STRBUF+3 ; add one if post sign
2199 L9167 lda #'+ ; positive sign
2200 tstb ; is base 10 exponent positive?
2201 bpl L916F ; brif so
2202 lda #'- ; negative sign
2203 negb ; flip exponent
2204 L916F sta 1,u ; put exponent sign
2205 lda #'E ; put "E" and advance output pointer
2206 sta ,u++
2207 lda #'0-1 ; initialize digit accumulator
2208 L9177 inca ; bump digit
2209 subb #10 ; are we at the right digit?
2210 bcc L9177 ; brif not
2211 addb #'0+10 ; add ASCII bias and undo extra subtraction
2212 std ,u++ ; save exponent in buffer
2213 clr ,u ; clear final byte in buffer
2214 jmp L9054 ; insert *, $, etc.
2215 L9185 ldx #STRBUF+4 ; point to start of result
2216 ldb ,x ; get sign
2217 pshs b ; save it
2218 lda #0x20 ; default pad with spaces
2219 ldb VDA ; get flags
2220 bitb #0x20 ; padding with *?
2221 puls b
2222 beq L919E ; brif no padding
2223 lda #'* ; pad with *
2224 cmpb #0x20 ; do we have a blank? (positive)
2225 bne L919E ; brif not
2226 tfr a,b ; use pad character
2227 L919E pshs b ; save first character
2228 L91A0 sta ,x+ ; store padding
2229 ldb ,x ; get next character
2230 beq L91B6 ; brif end of string
2231 cmpb #'E ; exponent?
2232 beq L91B6 ; brif so - treat as 0
2233 cmpb #'0 ; zero?
2234 beq L91A0 ; brif so - pad it
2235 cmpb #', ; leading comma?
2236 beq L91A0 ; brif so - pad it
2237 cmpb #'. ; decimal?
2238 bne L91BA ; brif so - don't put a 0 before it
2239 L91B6 lda #'0 ; put a zero before
2240 sta ,-x
2241 L91BA lda VDA ; get status byte
2242 bita #0x10 ; floating $?
2243 beq L91C4 ; brif not
2244 ldb #'$ ; stuff a $ in
2245 stb ,-x
2246 L91C4 anda #4 ; pre-sgn?
2247 puls b ; get back first character
2248 bne L91CC ; brif not
2249 stb ,-x ; save leading character (sign)
2250 L91CC rts
2251 L91CD pshs u ; save buffer pointer
2252 clra ; initial exponent offset is 0
2253 L91D0 sta V47 ; save exponent offset
2254 ldb FP0EXP ; get actual exponent
2255 cmpb #0x80 ; is value >= 1.0?
2256 bhi L91E9 ; brif so
2257 ldx #LBDC0 ; point to FP number 1E9
2258 jsr LBACA ; multiply by 1000000000
2259 lda V47 ; account for 9 shifts
2260 suba #9
2261 bra L91D0 ; brif not there yet
2262 L91E4 jsr LBB82 ; divide by 10
2263 inc V47 ; account for shift
2264 L91E9 ldx #LBDBB ; point to 999999999
2265 jsr LBCA0 ; compare it
2266 bgt L91E4 ; brif not in range yet
2267 L91F1 ldx #LBDB6 ; point to 99999999.9
2268 jsr LBCA0 ; compare
2269 bgt L9200 ; brif in range
2270 jsr LBB6A ; multiply by 10
2271 dec V47 ; account for shift
2272 bra L91F1 ; see if we're in range yet
2273 L9200 puls u,pc ; restore buffer pointer and return
2274 L9202 pshs u ; save buffer pointer
2275 jsr LB9B4 ; add .5 (round off)
2276 jsr LBCC8 ; convert to integer format
2277 puls u ; restore buffer pointer
2278 ldx #LBEC5 ; point to 32 bit powers of 10 (alternating signs)
2279 ldb #0x80 ; intitial digit counter is 0 with 0x80 bias
2280 L9211 bsr L9249 ; check for comma
2281 L9213 lda FPA0+3 ; add a power of 10
2282 adda 3,x
2283 sta FPA0+3
2284 lda FPA0+2
2285 adca 2,x
2286 sta FPA0+2
2287 lda FPA0+1
2288 adca 1,x
2289 sta FPA0+1
2290 lda FPA0
2291 adca ,x
2292 sta FPA0
2293 incb ; add one to digit counter
2294 rorb ; set V if carry and sign differ
2295 rolb
2296 bvc L9213 ; brif we haven't "wrapped"
2297 bcc L9235 ; brif subtracting
2298 subb #10+1 ; take 9's complement if adding
2299 negb
2300 L9235 addb #'0-1 ; add in ASCII bias
2301 leax 4,x ; move to next power
2302 tfr b,a ; save digit
2303 anda #0x7f ; mask off subtract flag
2304 sta ,u+ ; save digit
2305 comb ; toggle add/subtract
2306 andb #0x80
2307 cmpx #LBEE9 ; done all places?
2308 bne L9211 ; brif not
2309 clr ,u ; but NUL at end
2310 L9249 dec V45 ; at decimal?
2311 bne L9256 ; brif not
2312 L924D stu VARPTR ; save decimal point pointer
2313 lda #'. ; insert decimal
2314 sta ,u+
2315 clr VD7 ; clear comma counter
2316 rts
2317 L9256 dec VD7 ; do we need a comma?
2318 bne L9262 ; brif not
2319 lda #3 ; reset comma counter
2320 sta VD7
2321 lda #', ; insert comma
2322 sta ,u+
2323 L9262 rts
2324 L9263 lda V47 ; get base 10 exponent offset
2325 adda #10 ; account for significant figures
2326 sta V45 ; save decimal counter
2327 inca ; add one for decimal point
2328 L926A suba #3 ; divide by 3, leave remainder in A
2329 bcc L926A
2330 adda #5 ; renormalize to range 1-3
2331 sta VD7 ; save comma counter
2332 lda VDA ; get status
2333 anda #0x40 ; commas wanted?
2334 bne L927A ; brif not
2335 sta VD7 ; clear comma counter
2336 L927A rts
2337 L927B pshs a ; save zeroes counter
2338 bsr L9249 ; check for decimal
2339 puls a ; get back counter
2340 L9281 deca ; need a zero?
2341 bmi L928E ; brif not
2342 pshs a ; save counter
2343 lda #'0 ; put a zero
2344 sta ,u+
2345 lda ,s+ ; get back counter and set flags
2346 bne L927B ; brif not done enough
2347 L928E rts
2348 ; From here to the end of the Extended Basic ROM is the PMODE graphics system and related
2349 ; infrastructure with the exception of the PLAY command which shares some of its machinery
2350 ; with the DRAW command.
2351 ;
2352 ; Fetch screen address calculation routine address for the selected graphics mode
2353 L928F ldu #L929C ; point to normalization routine jump table
2354 lda PMODE ; get graphics mode
2355 asla ; two bytes per address
2356 ldu a,u ; get routine address
2357 rts
2358 ; Normalize VERBEG/HORBEG coordinates and return screen address in X and pixel mask in A.
2359 L9298 bsr L928F ; fetch normalization routine pointer
2360 jmp ,u ; transfer control to it
2361 L929C fdb L92A6 ; PMODE 0
2362 fdb L92C2 ; PMODE 1
2363 fdb L92A6 ; PMODE 2
2364 fdb L92C2 ; PMODE 3
2365 fdb L92A6 ; PMODE 4
2366 ; Two colour mode address calculatoin
2367 L92A6 pshs u,b ; savce registers
2368 ldb HORBYT ; get number of bytes in each graphics row
2369 lda VERBEG+1 ; get vertical coordinate
2370 mul
2371 addd BEGGRP ; now D is the absolute address of the start of the row
2372 tfr d,x ; get address to the return location
2373 ldb HORBEG+1 ; get horizontal coordinate
2374 lsrb ; divide by 8 (8 pixels per byte in 2 colour mode)
2375 lsrb
2376 lsrb
2377 abx ; now X is the address of the actual pixel byte
2378 lda HORBEG+1 ; get horizontal coordinate
2379 anda #7 ; keep only the low 3 bits which contain the pixel number
2380 ldu #L92DD ; point to pixel mask lookup
2381 lda a,u ; get pixel mask
2382 puls b,u,pc ; restore registers and return result
2383 ; four colour address calculation
2384 L92C2 pshs u,b ; save registers
2385 ldb HORBYT ; get bytes per graphics row
2386 lda VERBEG+1 ; get vertical coordinate
2387 mul
2388 addd BEGGRP ; now D is the address of the start of the row
2389 tfr d,x ; put it in returnlocatin
2390 ldb HORBEG+1 ; get horizontal coordinate
2391 lsrb ; divide by 4 (four colour modes have four pixels per byte)
2392 lsrb
2393 abx ; now X points to the screen byte
2394 lda HORBEG+1 ; get horizontal coordinate
2395 anda #3 ; keep low two bits for pixel number
2396 ldu #L92E5 ; point to four colour pixel masks
2397 lda a,u ; get pixel mask
2398 puls b,u,pc ; restore registers and return result
2399 L92DD fcb 0x80,0x40,0x20,0x10 ; two colour pixel masks
2400 fcb 0x08,0x04,0x02,0x01
2401 L92E5 fcb 0xc0,0x30,0x0c,0x03 ; four colour pixel masks
2402 ; Move X down one graphics row
2403 L92E9 ldb HORBYT ; get bytes per row
2404 abx ; add to screen address
2405 rts
2406 ; Move one pixel right in 2 colour mode
2407 L92ED lsra ; move pixel mask right
2408 bcc L92F3 ; brif same byte
2409 rora ; move pixel mask to left of byte
2410 leax 1,x ; move to next byte
2411 L92F3 rts
2412 ; Move one pixel right in 4 colour mode
2413 L92F4 lsra ; shift mask half a pixel right
2414 bcc L92ED ; brif not past end of byte - shift one more
2415 lda #0xc0 ; set mask on left of byte
2416 leax 1,x ; move to next byte
2417 rts
2418 ; Evaluate two expressions (coordinates). Put first in HORBEG and second in VERBEG.
2419 L92FC jsr LB734 ; evaluate two expressions - first in BINVAL, second in B
2420 ldy #HORBEG ; point to storage location
2421 L9303 cmpb #192 ; is vertical outside range?
2422 blo L9309 ; brif not
2423 ldb #191 ; max it at bottom of screen
2424 L9309 clra ; zero extend vertical coordinate
2425 std 2,y ; save vertical coordinate
2426 ldd BINVAL ; get horizontal coordinate
2427 cmpd #256 ; in range?
2428 blo L9317 ; brif so
2429 ldd #255 ; max it out to right side of screen
2430 L9317 std ,y ; save horizontal coordinate
2431 rts
2432 ; Normalize coordinates for proper PMODE
2433 L931A jsr L92FC ; parse coordinates
2434 L931D ldu #HORBEG ; point to start coordinates
2435 L9320 lda PMODE ; get graphics mode
2436 cmpa #2 ; is it pmode 0 or 1?
2437 bhs L932C ; brif not
2438 ldd 2,u ; get vertical coordinate
2439 lsra ; divide it by two
2440 rorb
2441 std 2,u ; save it back
2442 L932C lda PMODE ; get graphics mode
2443 cmpa #4 ; pmode 4?
2444 bhs L9338 ; brif so
2445 ldd ,u ; cut horizontal coordinate in half
2446 lsra
2447 rorb
2448 std ,u ; save new coordinate
2449 L9338 rts
2450 ; PPOINT function
2451 PPOINT jsr L93B2 ; evaluate two expressions (coordinates)
2452 jsr L931D ; normalize coordinates
2453 jsr L9298 ; get screen address
2454 anda ,x ; get colour value of desired screen coordinate
2455 ldb PMODE ; get graphics mode
2456 rorb ; is it a two colour m ode?
2457 bcc L935B ; brif so
2458 L9349 cmpa #4 ; is it on rightmost bits?
2459 blo L9351 ; brif not
2460 rora ; shift right
2461 rora
2462 bra L9349 ; see if we're there yet
2463 L9351 inca ; colour numbers start at 1
2464 asla ; add in colour set (0 or 8)
2465 adda CSSVAL
2466 lsra ; get colour in range of 0 to 8
2467 L9356 tfr a,b ; put result to B
2468 jmp LB4F3 ; return B as FP number
2469 L935B tsta ; is pixel on?
2470 beq L9356 ; brif not, return 0 (off)
2471 clra ; set colour number to "1"
2472 bra L9351 ; make it 1 or 5 and return
2473 ; PSET command
2474 PSET lda #1 ; PSET flag
2475 bra L9366 ; go turn on the pixel
2476 ; PRESET command
2477 PRESET clra ; PRESET flag
2478 L9366 sta SETFLG ; store whether we're setting or resetting
2479 jsr LB26A ; enforce (
2480 jsr L931A ; evaluate coordinates
2481 jsr L9581 ; evaluate colour
2482 jsr LB267 ; enforce )
2483 jsr L9298 ; get address of pixel
2484 L9377 ldb ,x ; get screen data
2485 pshs b ; save it
2486 tfr a,b ; duplicate pixel mask
2487 coma ; invert mask
2488 anda ,x ; turn off screen pixel
2489 andb ALLCOL ; adjust pixel mask to be the current colour
2490 pshs b ; merge pixel data into the screen data
2491 ora ,s+
2492 sta ,x ; put it on screen
2493 suba ,s+ ; nonzero if screen data changed
2494 ora CHGFLG ; propagate change flag
2495 sta CHGFLG
2496 rts
2497 ; Evaluate two sets of coordinates separated by a minus sign. First at HORBEG,VERBEG and
2498 ; second at HOREND,VEREND. If no first set, use HORDEF,VERDEF.
2499 L938F ldx HORDEF ; set default start coords
2500 stx HORBEG
2501 ldx VERDEF
2502 stx VERBEG
2503 cmpa #0xac ; do we start with a -?
2504 beq L939E ; brif no starting coordinates
2505 jsr L93B2 ; parse coordinates
2506 L939E ldb #0xac ; make sure we have a -
2507 jsr LB26F
2508 jsr LB26A ; require a (
2509 jsr LB734 ; evaluate two expressions
2510 ldy #HOREND ; point to storage location
2511 jsr L9303 ; process coordinates
2512 bra L93B8 ; finish up with a )
2513 L93B2 jsr LB26A ; make sure there's a (
2514 jsr L92FC ; evaluate coordinates
2515 L93B8 jmp LB267 ; force a )
2516 ; LINE command
2517 LINE cmpa #0x89 ; is it LINE INPUT?
2518 lbeq L89C0 ; brif so - go handle it
2519 cmpa #'( ; starting coord?
2520 beq L93CE ; brif so
2521 cmpa #0xac ; leading -?
2522 beq L93CE ; brif so
2523 ldb #'@ ; if it isn't the above, make sure it's @
2524 jsr LB26F
2525 L93CE jsr L938F ; parse coordinates
2526 ldx HOREND ; set ending coordinates as the defaults
2527 stx HORDEF
2528 ldx VEREND
2529 stx VERDEF
2530 jsr SYNCOMMA ; make sure we have a comma
2531 cmpa #0xbe ; PRESET?
2532 beq L93E9 ; brif so
2533 cmpa #0xbd ; PSET?
2534 lbne LB277 ; brif not
2535 ldb #01 ; PSET flag
2536 skip1lda ; skip byte and set A nonzero
2537 L93E9 clrb ; PRESET flag
2538 pshs b ; save PSET/PRESET flag
2539 jsr GETNCH ; eat the PSET/PRESET
2540 jsr L9420 ; normalize coordinates
2541 puls b ; get back PSET/PRESET flag
2542 stb SETFLG ; flag which we're doing
2543 jsr L959A ; set colour byte
2544 jsr GETCCH ; get next bit
2545 lbeq L94A1 ; brif no box option
2546 jsr SYNCOMMA ; make sure it's comma
2547 ldb #'B ; make sure "B" for "box"
2548 jsr LB26F
2549 bne L9429 ; brif something follows the B
2550 bsr L9444 ; draw horizontal line
2551 bsr L946E ; draw vertical line
2552 ldx HORBEG ; save horizontal coordinate
2553 pshs x ; save it
2554 ldx HOREND ; switch in horizontal end
2555 stx HORBEG
2556 bsr L946E ; draw vertical line
2557 puls x ; get back original start
2558 stx HORBEG ; put it back
2559 ldx VEREND ; do the same dance with the vertical end
2560 stx VERBEG
2561 bra L9444 ; draw horizontal line
2562 L9420 jsr L931D ; normalize the start coordinates
2563 ldu #HOREND ; point to end coords
2564 jmp L9320 ; normalize those coordinates
2565 L9429 ldb #'F ; make sure we have "BF" for "filled box"
2566 jsr LB26F
2567 bra L9434 ; fill the box
2568 L9430 leax -1,x ; move vertical coordinate up one
2569 L9432 stx VERBEG ; save new vertical coordinate
2570 L9434 jsr L9444 ; draw a horizontal line
2571 ldx VERBEG ; are we at the end of the box?
2572 cmpx VEREND
2573 beq L9443 ; brif so
2574 bcc L9430 ; brif we're moving up the screen
2575 leax 1,x ; move down the screen
2576 bra L9432 ; go draw another line
2577 L9443 rts
2578 ; Draw a horizontal line from HORBEG to HOREND at VERBEG using color mask in ALLCOL
2579 L9444 ldx HORBEG ; get starting horizontal coordinate
2580 pshs x ; save it
2581 jsr L971D ; get absolute value of HOREND-HORBEG
2582 bcc L9451 ; brif end is > start
2583 ldx HOREND ; copy end coordinate to start it is smaller
2584 stx HORBEG
2585 L9451 tfr d,y ; save difference - it's a pixel count
2586 leay 1,y ; coordinates are inclusive
2587 jsr L9298 ; get screen position of start coord
2588 puls u ; restore original start coordinate
2589 stu HORBEG
2590 bsr L9494 ; point to routine to move pizel pointers to right
2591 L945E sta VD7 ; save pixel mask
2592 jsr L9377 ; turn on pixel
2593 lda VD7 ; get pixel mask back
2594 jsr ,u ; move one pixel right
2595 leay -1,y ; turned on enough pixels yet?
2596 bne L945E ; brif not
2597 L946B rts
2598 L946C puls b,a ; clean up stack
2599 L946E ldd VERBEG ; save original vertical start coordinate
2600 pshs b,a
2601 jsr L9710 ; get vertical difference
2602 bcc L947B ; brif end coordinate > start
2603 ldx VEREND ; swap in end coordinate if not
2604 stx VERBEG
2605 L947B tfr d,y ; save number of pixels to set
2606 leay 1,y ; the coordinates are inclusive
2607 jsr L9298 ; get screen pointer
2608 puls u ; restore start coordinate
2609 stu VERBEG
2610 bsr L949D ; point to routine to move down one row
2611 bra L945E ; draw vertical line
2612 ; Point to routine which will move one pixel right
2613 L948A fdb L92ED ; PMODE 0
2614 fdb L92F4 ; PMODE 1
2615 fdb L92ED ; PMODE 2
2616 fdb L92F4 ; PMODE 3
2617 fdb L92ED ; PMODE 4
2618 L9494 ldu #L948A ; point to jump table
2619 ldb PMODE ; get graphics mode
2620 aslb ; two bytes per address
2621 ldu b,u ; get jump address
2622 rts
2623 ; Point to routine to move down one row
2624 L949D ldu #L92E9 ; point to "move down one row" routien
2625 rts
2626 ; Draw a line from HORBEG,VERBEG to HOREND,VEREND
2627 L94A1 ldy #L950D ; point to increase vertical coord
2628 jsr L9710 ; calculate difference
2629 lbeq L9444 ; brif none - draw a horizontal line
2630 bcc L94B2 ; brif vertical end is > vertical start
2631 ldy #L951B ; point to decrease vertical coord
2632 L94B2 pshs d ; save vertical difference
2633 ldu #L9506 ; point to increase horizontal coord
2634 jsr L971D ; get difference
2635 beq L946C ; brif none - draw a vertical line
2636 bcc L94C1 ; brif horizontal end > horizontal start
2637 ldu #L9514 ; point to decrease hoizontal coord
2638 L94C1 cmpd ,s ; compare vert and horiz differences
2639 puls x ; get X difference
2640 bcc L94CC ; brif horiz diff > vert diff
2641 exg u,y ; swap change routine pointers
2642 exg d,x ; swap differences
2643 L94CC pshs u,d ; save larger difference and routine
2644 pshs d ; save larger difference
2645 lsra ; divide by two
2646 rorb
2647 bcs L94DD ; brif odd number
2648 cmpu #L950D+1 ; increase or decrease?
2649 blo L94DD ; brif increase
2650 subd #1 ; back up one
2651 L94DD pshs x,b,a ; save smallest difference and initial middle offset
2652 jsr L928F ; point to proper coordinate to screen conversion routine
2653 L94E2 jsr ,u ; convert coordinates to screen address
2654 jsr L9377 ; turn on a pixel
2655 ldx 6,s ; get distnace counter
2656 beq L9502 ; brif line is completely drawn
2657 leax -1,x ; account for one pixel drawn
2658 stx 6,s ; save new counter
2659 jsr [8,s] ; increment/decrement larger delta
2660 ldd ,s ; get the minor coordinate increment counter
2661 addd 2,s ; add the smallest difference
2662 std ,s ; save new minor coordinate incrementcounter
2663 subd 4,s ; subtractout the largest difference
2664 bcs L94E2 ; brif not greater - draw another pixel
2665 std ,s ; save new minor coordinate increment
2666 jsr ,y ; adjust minor coordinate
2667 bra L94E2 ; go draw another pixel
2668 L9502 puls x ; clean up stack and return
2669 puls a,b,x,y,u,pc
2670 L9506 ldx HORBEG ; bump horizontal coordinate
2671 leax 1,x
2672 stx HORBEG
2673 rts
2674 L950D ldx VERBEG ; bump vertical coordinate
2675 leax 1,x
2676 stx VERBEG
2677 rts
2678 L9514 ldx HORBEG ; decrement horizontal coordinate
2679 leax -1,x
2680 stx HORBEG
2681 rts
2682 L951B ldx VERBEG ; decrement vertical coordinate
2683 leax -1,x
2684 stx VERBEG
2685 rts
2686 ; Get normalized maximum coordinate values in VD3 and VD5
2687 L9522 ldu #VD3 ; point to temp storage
2688 ldx #255 ; set maximum horizontal
2689 stx ,u
2690 ldx #191 ; set maximum vertical
2691 stx 2,u
2692 jmp L9320 ; normalize them
2693 ; PCLS command
2694 PCLS beq L9542 ; clear to background colour if no argument
2695 bsr L955A ; evaluate colour
2696 L9536 lda #0x55 ; consider each byte as 4 groups of 2 bit sub-nibbles
2697 mul ; now colour is in all four sub-pixels
2698 ldx BEGGRP ; get start of graphics screen
2699 L953B stb ,x+ ; set byte to proper colour
2700 cmpx ENDGRP ; at end of graphics page?
2701 bne L953B ; brif not
2702 rts
2703 L9542 ldb BAKCOL ; get background colour
2704 bra L9536 ; do the clearing dance
2705 ; COLOR command
2706 COLOR cmpa #', ; check for comma
2707 beq L9552 ; brif no foreground colour
2708 bsr L955A ; evaluate first colour
2709 stb FORCOL ; set foreground colour
2710 jsr GETCCH ; is there a background colour?
2711 beq L9559 ; brif not
2712 L9552 jsr SYNCOMMA ; make sure we have a comma
2713 bsr L955A ; evaluate background colour argument
2714 stb BAKCOL ; set background colour
2715 L9559 rts
2716 ; Evaluate a colour agument and convert to proper code based on graphics mode
2717 L955A jsr EVALEXPB ; evaluate colour code
2718 L955D cmpb #9 ; is it in range of 0-8?
2719 lbhs LB44A ; brif not - raise error
2720 clra ; CSS value for first colour set
2721 cmpb #5 ; is it first or second colour set?
2722 blo L956C ; brif first colour set
2723 lda #8 ; flag second colour set
2724 subb #4 ; adjust into basic range
2725 L956C pshs a ; save CSS value
2726 lda PMODE ; get graphics mode
2727 rora ; 4 colour or 2?
2728 bcc L957B ; brif 2 colour
2729 tstb ; was it 0?
2730 bne L9578 ; brif not
2731 L9576 ldb #4 ; if so, make it 4
2732 L9578 decb ; convert to zero based
2733 L9579 puls a,pc ; get back CSS value and return
2734 L957B rorb ; is colour number odd?
2735 bcs L9576 ; brif so - force all bits set colour
2736 clrb ; force colour 0 if not
2737 bra L9579
2738 ; Set all pixel byte and active colour
2739 L9581 jsr L959A ; set colour byte
2740 jsr GETCCH ; is there something to evaluate?
2741 beq L9598 ; brif not
2742 cmpa #') ; )?
2743 beq L9598 ; brif so
2744 jsr SYNCOMMA ; force comma
2745 cmpa #', ; another comma?
2746 beq L9598 ; brif so
2747 jsr L955A ; evaluate expression and return colour
2748 bsr L95A2 ; save colour and pixel byte
2749 L9598 jmp GETCCH ; re-fetch input character and return
2750 L959A ldb FORCOL ; use foreground colour by default
2751 tst SETFLG ; doing PRESET?
2752 bne L95A2 ; brif not
2753 ldb BAKCOL ; default to background colour
2754 L95A2 stb WCOLOR ; save working colour
2755 lda #0x55 ; consider a byte as 4 pixels
2756 mul ; now all pixels are set to the same bit pattern
2757 stb ALLCOL ; set all pixels byte
2758 rts
2759 L95AA bne L95CF ; brif graphics mode
2760 L95AC pshs x,b,a ; save registers
2761 ldx #SAMREG+8 ; point to middle of control register
2762 sta 10,x ; reset display page to 0x400
2763 sta 8,x
2764 sta 6,x
2765 sta 4,x
2766 sta 2,x
2767 sta 1,x
2768 sta -2,x
2769 sta -4,x ; reset to alpha mode
2770 sta -6,x
2771 sta -8,x
2772 lda PIA1+2 ; set VDG to alpha mode, colour set 0
2773 anda #7
2774 sta PIA1+2
2775 puls a,b,x,pc ;restore registers and return
2776 L95CF pshs x,b,a ; save registers
2777 lda PMODE ; get graphics mode
2778 adda #3 ; offset to 3-7 (we don't use the bottom 3 modes)
2779 ldb #0x10 ; shift to high 4 bits
2780 mul
2781 orb #0x80 ; set to graphics mode
2782 orb CSSVAL ; set the desired colour set
2783 lda PIA1+2 ; get get original PIA values
2784 anda #7 ; mask off VDG control
2785 pshs a ; merge with new VDG control
2786 orb ,s+
2787 stb PIA1+2 ; set new VDG mode
2788 lda BEGGRP ; get start of graphics page
2789 lsra ; divide by two - pages are on 512 byte boundaries
2790 jsr L960F ; set SAM control register
2791 lda PMODE ; get graphics mode
2792 adda #3 ; shift to VDG values
2793 cmpa #7 ; PMODE 4?
2794 bne L95F7 ; brif not
2795 deca ; treat PMODE 4 the same as PMODE 3
2796 L95F7 bsr L95FB ; program SAM's VDG bits
2797 puls a,b,x,pc ; restore registers and return
2798 L95FB ldb #3 ; set 3 bits in register
2799 ldx #SAMREG ; point to VDG control bits
2800 L9600 rora ; get bit to set
2801 bcc L9607 ; brif we need to clear the bit
2802 sta 1,x ; set the bit
2803 bra L9609
2804 L9607 sta ,x ; clear the bit
2805 L9609 leax 2,x ; move to next bit
2806 decb ; done all bits?
2807 bne L9600 ; brif not
2808 rts
2809 L960F ldb #7 ; 7 screen address bits
2810 ldx #SAMREG+6 ; point to screen address bits in SAM
2811 bra L9600 ; go program SAM bits
2812 L9616 lda PIA1+2 ; get VDG bits
2813 anda #0xf7 ; keep everything but CSS bit
2814 ora CSSVAL ; set correct CSS bit
2815 sta PIA1+2 ; set desired CSS
2816 rts
2817 ; PMODE command
2818 PMODETOK cmpa #', ; is first argument missing?
2819 beq L9650 ; brif so
2820 jsr EVALEXPB ; evaluate PMODE number
2821 cmpb #5 ; valid (0-4)?
2822 bhs L966D ; brif not
2823 lda GRPRAM ; get start of graphics memory
2824 L962E sta BEGGRP ; set start of graphics page
2825 aslb ; multiply mode by two (table has two bytes per entry)
2826 ldu #L9706+1 ; point to lookup table
2827 adda b,u ; add in number of 256 byte pages used for graphics screen
2828 cmpa TXTTAB ; does it fit?
2829 bhi L966D ; brif not
2830 sta ENDGRP ; save end of graphics
2831 leau -1,u ; point to bytes per horizontal row
2832 lda b,u ; get bytes per row
2833 sta HORBYT ; set it
2834 lsrb ; restore PMODE value
2835 stb PMODE ; set graphics mode
2836 clra ; set background colour to 0
2837 sta BAKCOL
2838 lda #3 ; set foreground colour to maximum (3)
2839 sta FORCOL
2840 jsr GETCCH ; is there a starting page number?
2841 beq L966C ; brif not
2842 L9650 jsr LB738 ; evaluate an expression following a comma
2843 tstb ; page 0?
2844 beq L966D ; brif so - not valid
2845 decb ; zero-base it
2846 lda #6 ; each graphics page is 6*256
2847 mul
2848 addb GRPRAM ; add to start of graphics memory
2849 pshs b ; save start of screen memory
2850 addb ENDGRP ; add current and address
2851 subb BEGGRP ; subtract current start (adds size of screen)
2852 cmpb TXTTAB ; does it fit?
2853 bhi L966D ; brif not
2854 stb ENDGRP ; save new end of graphics
2855 puls b ; get back start of graphics
2856 stb BEGGRP ; set start of graphics
2857 L966C rts
2858 L966D jmp LB44A ; raise FC error
2859 ; SCREEN command
2860 SCREEN cmpa #', ; is there a mode?
2861 beq L967F ; brif no mode
2862 jsr EVALEXPB ; get mode argument
2863 tstb ; set Z if alpha
2864 jsr L95AA ; set SAM/VDG for graphics mode
2865 jsr GETCCH ; is there a second argument?
2866 beq L966C ; brif not
2867 L967F jsr LB738 ; evaluate ,<expr>
2868 tstb ; colour set 0?
2869 beq L9687 ; brif so
2870 ldb #8 ; flag for colour set 1
2871 L9687 stb CSSVAL ; set colour set
2872 bra L9616 ; set up VDG
2873 ; PCLEAR command
2874 PCLEAR jsr EVALEXPB ; evaulate number of pages requested
2875 tstb ; 0?
2876 beq L966D ; brif zero - not allowed
2877 cmpb #9 ; more than 8?
2878 bhs L966D ; brif so - not allowed
2879 lda #6 ; there are 6 "pages" per graphics page
2880 mul ; now B is the number of pages to reserve
2881 addb GRPRAM ; add to start of graphics memory
2882 tfr b,a ; now A is the MSB of the start of free memory
2883 ldb #1 ; program memory always starts one above
2884 tfr d,y ; save pointer to program memory
2885 cmpd ENDGRP ; are we trying to deallocate the current graphics page?
2886 blo L966D ; brif so (note that this prevents PCLEAR 0 anyway)
2887 subd TXTTAB ; subtract out current start of basic program
2888 addd VARTAB ; add in end of program - now D is new top of program
2889 tfr d,x ; save new end of program
2890 inca ; make some extra space (for stack)
2891 subd FRETOP ; see if new top of program fits
2892 bhs L966D ; brif there isn't enough space
2893 jsr L80D0 ; adjust input pointer
2894 nop ; space filler for 1.1 patch (the JSR above)
2895 ldu VARTAB ; get end of program
2896 stx VARTAB ; save new end of program
2897 cmpu VARTAB ; is old end higher?
2898 bhs L96D4 ; brif so
2899 L96BD lda ,-u ; copy a byte upward
2900 sta ,-x
2901 cmpu TXTTAB ; at beginning?
2902 bne L96BD ; brif not
2903 sty TXTTAB ; save new start of program
2904 clr -1,y ; there must always be a NUL before the program
2905 L96CB jsr LACEF ; re-assign basic program addresses
2906 jsr LAD26 ; reset variables and stack
2907 jmp LAD9E ; return to interpretation loop
2908 L96D4 ldu TXTTAB ; get start of program
2909 sty TXTTAB ; save new start of program
2910 clr -1,y ; there must be a NUL at the start of the program
2911 L96DB lda ,u+ ; move a byte downward
2912 sta ,y+
2913 cmpy VARTAB ; at the top of the program?
2914 bne L96DB ; brif not
2915 bra L96CB ; finish up
2916 ; Graphics initialization routine - this really should be up at the start of the ROM with the
2917 ; rest of the initialization code.
2918 L96E6 ldb #0x1e ; set start of program to 0x1e00 ("PCLEAR 4")
2919 stb TXTTAB
2920 lda #6 ; graphics memory starts immediately after the screen
2921 L96EC sta GRPRAM ; set graphics memory start
2922 sta BEGGRP ; set start of current graphics page
2923 clra ; set PMODE to 0
2924 sta PMODE
2925 lda #16 ; 16 bytes per graphics row
2926 sta HORBYT
2927 lda #3 ; set foreground colour to 3
2928 sta FORCOL
2929 lda #0x0c ; set ending graphics page (for PMODE 0)
2930 sta ENDGRP
2931 ldx TXTTAB ; get start of program
2932 clr -1,x ; make sure there's a NUL before it
2933 L9703 jmp LAD19 ; do a "NEW"
2934 ; PMODE data table (bytes per row and number of 256 byte pages required for a screen)
2935 L9706 fcb 16,6 ; PMODE 0
2936 fcb 32,12 ; PMODE 1
2937 fcb 16,12 ; PMODE 2
2938 fcb 32,24 ; PMODE 3
2939 fcb 32,24 ; PMODE 4
2940 ; Calculate absolute value of vertical coordinate difference
2941 L9710 ldd VEREND ; get ending address
2942 subd VERBEG ; get difference
2943 L9714 bcc L9751 ; brif we didn't carry
2944 pshs cc ; save status (C set if start > end)
2945 jsr L9DC3 ; negate the difference to be positive
2946 puls cc,pc ; restore C and return
2947 ; Calculate absolute value of horizontal coordinate difference
2948 L971D ldd HOREND ; get end coordinate
2949 subd HORBEG ; calculate difference
2950 bra L9714 ; turn into absolute value
2951 ; PCOPY command
2952 PCOPY bsr L973F ; fetch address of the source page
2953 pshs d ; save address
2954 ldb #0xa5 ; make sure we have TO
2955 jsr LB26F
2956 bsr L973F ; fetch address of the second page
2957 puls x ; get back source
2958 tfr d,u ; put destination into a pointer
2959 ldy #0x300 ; 0x300 words to copy
2960 L9736 ldd ,x++ ; copy a word
2961 std ,u++
2962 leay -1,y ; done?
2963 bne L9736 ; brif not
2964 rts
2965 L973F jsr EVALEXPB ; evaluate page number
2966 tstb ; zero?
2967 beq L9752 ; brif invalid page number
2968 ; BUG: this should be deferred until after the address is calculated at which point it should
2969 ; be bhs instead of bhi. There should also be a check to make sure the page number is less than
2970 ; or equal to 8 above so we don't have to test for overflows below.
2971 cmpb TXTTAB ; is page number higher than start of program (BUG!)
2972 bhi L9752 ; brif so - error
2973 decb ; zero-base the page number
2974 lda #6 ; 6 "pages" per graphics page
2975 mul ; now we have proper number of "pages" for the offset
2976 addb GRPRAM ; add start of graphics memory
2977 exg a,b ; put MSB into A, 0 into B.
2978 L9751 rts
2979 L9752 jmp LB44A ; raise illegal function call
2980 ; GET command
2981 GET clrb ; GET flag
2982 bra L975A ; go on to the main body
2983 PUT ldb #1 ; PUT flag
2984 L975A stb VD8 ; save GET/PUT flag
2985 jsr RVEC22 ; do the RAM hook dance (so Disk Basic can do its thing)
2986 L975F cmpa #'@ ; @ before coordinates?
2987 bne L9765 ; brif not
2988 jsr GETNCH ; eat the @
2989 L9765 jsr L938F ; evaluate start/end coordinates
2990 jsr SYNCOMMA ; make sure we have a comma
2991 jsr L98CC ; get pointer to array
2992 tfr X,D ; save descriptor pointer
2993 ldu ,x ; get offset to next descriptor
2994 leau -2,u ; move back to array name
2995 leau d,u ; point to end of array
2996 stu VD1 ; save end of data
2997 leax 2,x ; point to number of dimensions
2998 ldb ,x ; get dimension count
2999 aslb ; two bytes per dimension size
3000 abx ; now X points to start of data
3001 stx VCF ; save start of array data
3002 lda VALTYP ; is it numeric
3003 bne L9752 ; brif not
3004 clr VD4 ; set default graphic action to PSET
3005 jsr GETCCH ; get input character
3006 beq L97B7 ; brif no action flag
3007 com VD4 ; flag action enabled
3008 jsr SYNCOMMA ; make sure there's a comma
3009 tst VD8 ; PUT?
3010 bne L979A ; brif so
3011 ldb #'G ; check for full graphics option
3012 jsr LB26F
3013 bra L97CA ; handle the rest of the process
3014 L979A ldb #5 ; 5 legal actions for PUT
3015 ldx #L9839 ; point to action table
3016 L979F ldu ,x++ ; get "clear bit" action routine
3017 ldy ,x++ ; get "set bit" action routine
3018 cmpa ,x+ ; does token match?
3019 beq L97AE ; brif so
3020 decb ; checked all?
3021 bne L979F ; brif not
3022 jmp LB277 ; raise error
3023 L97AE sty VD5 ; save set bit action address
3024 stu VD9 ; save clear bit action address
3025 jsr GETNCH ; munch the acton token
3026 bra L97CA ; handle rest of process
3027 L97B7 ldb #0xf8 ; mask for bottom three bits
3028 lda PMODE ; get graphics mode
3029 rora ; odd number mode?
3030 bcc L97C0 ; brif even
3031 ldb #0xfc ; bottom 2 bits mask
3032 L97C0 tfr b,a ; save mask
3033 andb HORBEG+1 ; round down the start address
3034 stb HORBEG+1
3035 anda HOREND+1 ; round down end address
3036 sta HOREND+1
3037 L97CA jsr L971D ; get horizontal size
3038 bcc L97D3 ; brif end > start
3039 ldx HOREND ; switch end in for start
3040 stx HORBEG
3041 L97D3 std HOREND ; save size
3042 jsr L9710 ; calculate vertical size
3043 bcc L97DE ; brif end > start
3044 ldx VEREND ; swap in vertical end for the start
3045 stx VERBEG
3046 L97DE std VEREND ; save vertical size
3047 lda PMODE ; get graphics mode
3048 rora ; even?
3049 ldd HOREND ; get difference
3050 bcc L97EB ; brif even (2 colour)
3051 addd HOREND ; add in size (double it)
3052 std HOREND ; save adjusted end size
3053 L97EB jsr L9420 ; normalize differences
3054 ldd HOREND ; get end coord
3055 ldx VEREND ; get end size
3056 leax 1,x ; make vertical size inclusive
3057 stx VEREND ; save it back
3058 tst VD4 ; got "G" or GET action
3059 bne L9852 ; brif given
3060 lsra ; we're going for whole bytes here
3061 rorb
3062 lsra
3063 rorb
3064 lsra
3065 rorb
3066 addd #1 ; make it inclusive
3067 std HOREND ; save new coordinate
3068 jsr L9298 ; convert to screen address
3069 L9808 ldb HOREND+1 ; get horizontal size
3070 pshs x ; save screen position
3071 L980C tst VD8 ; get/put flag
3072 beq L9831 ; brif get
3073 bsr L9823 ; bump array data pointer
3074 lda ,u ; copy data from array to screen
3075 sta ,x+
3076 L9816 decb ; are we done the row?
3077 bne L980C ; brif not
3078 puls x ; get screen address
3079 jsr L92E9 ; move to next row
3080 dec VEREND+1 ; done?
3081 bne L9808 ; brif not
3082 L9822 rts
3083 L9823 ldu VCF ; get array data location
3084 leau 1,u ; bump it
3085 stu VCF ; save new array data location
3086 cmpu VD1 ; did we hit the end of the array?
3087 bne L9822 ; brif not
3088 L982E jmp LB44A ; raise function call error
3089 L9831 lda ,x+ ; get data from screen
3090 bsr L9823 ; bump array data pointer
3091 sta ,u ; put data in array
3092 bra L9816 ; do the loopy thing
3093 ; PUT actions
3094 L9839 fdb L9894,L989B ; PSET
3095 fcb 0xbd
3096 fdb L989B,L9894 ; PRESET
3097 fcb 0xbe
3098 fdb L98B1,L989B ; OR
3099 fcb 0xb1
3100 fdb L9894,L98B1 ; AND
3101 fcb 0xb0
3102 fdb L98A1,L98A1 ; NOT
3103 fcb 0xa8
3104 L9852 addd #1 ; add to horiz difference
3105 std HOREND ; save it
3106 lda VD8 ; PUT?
3107 bne L9864 ; brif so
3108 ldu VD1 ; get end of array
3109 L985D sta ,-u ; zero out a byte
3110 cmpu VCF ; done?
3111 bhi L985D ; brif not
3112 L9864 jsr L9298 ; get screen address
3113 ldb PMODE ; get graphics mode
3114 rorb ; even?
3115 bcc L986E ; brif so
3116 anda #0xaa ; use as pixel mask for 4 colour mode
3117 L986E ldb #1 ; set bit probe
3118 ldy VCF ; point to start of array data
3119 L9873 pshs x,a ; save screen address
3120 ldu HOREND ; get horizontal size
3121 L9877 pshs u,a ; save horizontal size and pixel mask
3122 lsrb ; move bit probe right
3123 bcc L9884 ; brif we didn't fall off a byte
3124 rorb ; shift carry back in on the left
3125 leay 1,y ; move ahead a byte in the array
3126 cmpy VD1 ; end of array data?
3127 beq L982E ; raise error if so
3128 L9884 tst VD8 ; PUT?
3129 beq L98A7 ; brif not
3130 bitb ,y ; test bit in array
3131 beq L9890 ; brif not set
3132 jmp [VD5] ; do action routine for bit set
3133 L9890 jmp [VD9] ; do action routine for bit clear
3134 L9894 coma ; invert mask
3135 anda ,x ; read screen data and reset the desired bit
3136 sta ,x ; save on screen
3137 bra L98B1
3138 L989B ora ,x ; merge pixel mask with screen data (turn on bit)
3139 sta ,x ; save on screen
3140 bra L98B1
3141 L98A1 eora ,x ; invert the pixel in the screen data
3142 sta ,x ; save on screen
3143 bra L98B1
3144 L98A7 bita ,x ; is the bit set?
3145 beq L98B1 ; brif not - do nothing
3146 tfr b,a ; get bit probe
3147 ora ,y ; turn on proper bit in data
3148 sta ,y
3149 L98B1 puls a,u ; get back array address
3150 jsr L92ED ; move screen address to the right
3151 leau -1,u ; account for consumed pixel
3152 cmpu ZERO ; done yet?
3153 bne L9877 ; brif not
3154 ldx 1,s ; get start of row back
3155 lda HORBYT ; get number of bytes per row
3156 leax a,x ; move ahead one line
3157 puls a ; get back screen pixel mask
3158 leas 2,s ; lose the screen pointer
3159 dec VEREND+1 ; done all rows?
3160 bne L9873 ; brif not
3161 rts
3162 L98CC jsr LB357 ; evaluate a variable
3163 ldb ,-x ; get variable name
3164 lda ,-x
3165 tfr d,u ; save it
3166 ldx ARYTAB ; get start of arrays
3167 L98D7 cmpx ARYEND ; end of arrays?
3168 lbeq LB44A ; brif not found
3169 cmpu ,x ; correct variable?
3170 beq L98E8 ; brif so
3171 ldd 2,x ; get array size
3172 leax d,x ; move to next array
3173 bra L98D7 ; check this array
3174 L98E8 leax 2,x ; move pointer to the array header
3175 rts ; obviously this rts is not needed
3176 L98EB rts
3177 ; PAINT command
3178 PAINT cmpa #'@ ; do we have @ before coords?
3179 bne L98F2 ; brif not
3180 jsr GETNCH ; eat the @
3181 L98F2 jsr L93B2 ; evaluate coordinates
3182 jsr L931D ; normalize coordinates
3183 lda #1 ; PSET flag (use working colour)
3184 sta SETFLG
3185 jsr L9581 ; parse colour and set working colour, etc.
3186 ldd WCOLOR ; get working colour and all pixels byte
3187 pshs d ; save them
3188 jsr GETCCH ; is there anything else?
3189 beq L990A ; brif not
3190 jsr L9581 ; evaluate border colour
3191 L990A lda ALLCOL ; get border colour all pixel byte
3192 sta VD8 ; save border colour pixel byte
3193 puls d ; get back working colour details
3194 std WCOLOR
3195 clra ; store a "stop" frame on the stack so PAINT knows when it's finished unwinding
3196 pshs u,x,b,a
3197 jsr L9522 ; set up starting coordinates
3198 jsr L928F ; point to pixel mask routine
3199 stu VD9 ; save pixel mask routine
3200 jsr L99DF ; paint from current horizontal coordinate to zero (left)
3201 beq L9931 ; brif hit border immediately
3202 jsr L99CB ; paint from current horizontal coordinate upward (right)
3203 lda #1 ; set direction to "down"
3204 sta VD7
3205 jsr L99BA ; save "down" frame
3206 neg VD7 ; set direction to "up"
3207 jsr L99BA ; save "up" frame
3208 L9931 sts TMPSTK ; save stack pointer
3209 L9934 tst CHGFLG ; did the paint change anything?
3210 bne L993B ; brif so
3211 lds TMPSTK ; get back stack pointer
3212 L993B puls a,b,x,u ; get frame from stack
3213 clr CHGFLG ; mark nothing changed
3214 sts TMPSTK ; save stack pointer
3215 leax 1,x ; move start coordinate right
3216 stx HORBEG ; save new coordinate
3217 stu VD1 ; save length of line
3218 sta VD7 ; save up/down flag
3219 beq L98EB ; did we hit the "stop" frame?
3220 bmi L9954 ; brif negative going (up)?
3221 incb ; bump vertical coordinate
3222 cmpb VD6 ; at end?
3223 bls L9958 ; brif not
3224 clrb ; set vertical to 0 (wrap around)
3225 L9954 tstb ; did we wrap?
3226 beq L9934 ; do another block if so
3227 decb ; move up a row
3228 L9958 stb VERBEG+1 ; save vertical coordinate
3229 jsr L99DF ; paint from horizontal to 0
3230 beq L996E ; brif we hit the border immediately
3231 cmpd #3 ; less than 3 pixels?
3232 blo L9969 ; brif so
3233 leax -2,x ; move two pixels left
3234 bsr L99A1 ; save paint block on the stack
3235 L9969 jsr L99CB ; continue painting to the right
3236 L996C bsr L99BA ; save paint data frame
3237 L996E coma ; complement length of line just painted and add to length of line
3238 comb
3239 L9970 addd VD1 ; save difference between this line and parent line
3240 std VD1
3241 ble L998C ; brif parent line is shorter
3242 jsr L9506 ; bump horizontal coordinate
3243 jsr L9A12 ; see if we bounced into the border
3244 bne L9983 ; brif not border
3245 ldd #-1 ; move left
3246 bra L9970 ; keep looking
3247 L9983 jsr L9514 ; move horizontally left
3248 bsr L99C6 ; save horizontal coordinate
3249 bsr L99E8 ; paint right
3250 bra L996C ; save paint block and do more
3251 L998C jsr L9506 ; bump horizontal coordinate
3252 leax d,x ; point to right end of parent line
3253 stx HORBEG ; set as curent coordinate
3254 coma ; get amount we extend past parent line
3255 comb
3256 subd #1
3257 ble L999E ; brif doesn't extend
3258 tfr d,x ; save length of line
3259 bsr L99A1 ; save paint frame
3260 L999E jmp L9934
3261 L99A1 std VCB ; save number of pixels painted
3262 puls y ; get return address
3263 ldd HORBEG ; get horizontal coordinate
3264 pshs x,b,a ; save horizontal coordinate and pointer
3265 lda VD7 ; get up/down flag
3266 nega ; reverse it
3267 L99AC ldb VERBEG+1 ; get vertical coordainte
3268 pshs b,a ; save vertical coord and up/down flag
3269 pshs y ; put return address back
3270 ldb #2 ; make sure we haven't overflowed memory
3271 jsr LAC33
3272 ldd VCB ; get line length back
3273 rts
3274 L99BA std VCB ; save length of painted line
3275 puls y ; get return address
3276 ldd HOREND ; get start coord
3277 pshs x,b,a ; save horizontal start and length
3278 lda VD7 ; get up/down flag
3279 bra L99AC ; finish up with the stack
3280 L99C6 ldx HORBEG ; save current horizontal coord and save it
3281 stx HOREND
3282 rts
3283 L99CB std VCD ; save number of pixels painted
3284 ldy HOREND ; get last horizontal start
3285 bsr L99C6 ; save current coordinate
3286 sty HORBEG ; save coordinate
3287 bsr L99E8 ; paint a line
3288 ldx VCD ; get number painted
3289 leax d,x ; add to the number painted going the other way
3290 addd #1 ; now D is length of line
3291 rts
3292 L99DF jsr L99C6 ; put starting coordinate in end
3293 ldy #L9514 ; decrement horizontal coordinate address
3294 bra L99EE ; go paint line
3295 L99E8 ldy #L9506 ; increment horizontal coordinate address
3296 jsr ,y ; bump coordinate
3297 L99EE ldu ZERO ; initialize pixel count
3298 ldx HORBEG ; get starting coordinate
3299 L99F2 bmi L9A0B ; brif out of range for hoizontal coordinate
3300 cmpx VD3 ; at end?
3301 bhi L9A0B ; brif right of max
3302 pshs u,y ; save counter and inc/dec routine pointer
3303 bsr L9A12 ; at border?
3304 beq L9A09 ; brif so
3305 jsr L9377 ; set pixel to paint colour
3306 puls y,u ; restore counter and inc/dec/pointer
3307 leau 1,u ; bump number of painted pixels
3308 jsr ,y ; inc/dec screen address
3309 bra L99F2 ; go do another pixel
3310 L9A09 puls y,u ; get back counter and inc/dec routine
3311 L9A0B tfr u,d ; save count in D
3312 tfr d,x ; and in X
3313 subd ZERO ; set flags on D (smaller/faster than cmpd ZERO)
3314 rts
3315 L9A12 jsr [VD9] ; get the screen address
3316 tfr a,b ; save pixel mask
3317 andb VD8 ; set pixel to border colour
3318 pshs b,a ; save mask and border
3319 anda ,x ; mask current pixel into A
3320 cmpa 1,s ; does it match border? Z=1 if so
3321 puls a,b,pc ; restore mask, border pixel, and return
3322 ; PLAY command
3323 ; This is here mixed in with the graphics package because it shares some machinery with DRAW.
3324 PLAY ldx ZERO ; default values for note length, etc.
3325 ldb #1
3326 pshs x,b ; save default values
3327 jsr LB156 ; evaluate argument
3328 clrb ; enable DA and sound output
3329 jsr LA9A2
3330 jsr LA976
3331 L9A32 jsr LB654 ; fetch PLAY string details
3332 bra L9A39 ; go evaluate the string
3333 L9A37 puls b,x ; get back play string details
3334 L9A39 stb VD8 ; save length of string
3335 beq L9A37 ; brif end of string
3336 stx VD9 ; save start of string
3337 lbeq LA974 ; brif NULL string - disable sound and return
3338 L9A43 tst VD8 ; have anything left?
3339 beq L9A37 ; brif not
3340 jsr L9B98 ; get command character
3341 cmpa #'; ; command separator?
3342 beq L9A43 ; brif so - ignore it
3343 cmpa #'' ; '?
3344 beq L9A43 ; brif so - ignore it
3345 cmpa #'X ; execuate sub string?
3346 lbeq L9C0A ; brif so - handle it
3347 bsr L9A5C ; handle other commands
3348 bra L9A43 ; look for more stuff
3349 L9A5C cmpa #'O ; octave?
3350 bne L9A6D ; brif not
3351 ldb OCTAVE ; get current octave
3352 incb ; 1-base it
3353 bsr L9AC0 ; get value if present
3354 decb ; zero-base it
3355 cmpb #4 ; valid octave?
3356 bhi L9ACD ; raise error if not
3357 stb OCTAVE ; save new octave
3358 rts
3359 L9A6D cmpa #'V ; volume?
3360 bne L9A8B ; brif not
3361 ldb VOLHI ; get current high volume limit
3362 lsrb ; shift 2 bits right (DA is 6 bits in high bits)
3363 lsrb
3364 subb #31 ; subtract out mid value offset
3365 bsr L9AC0 ; read argument
3366 cmpb #31 ; maximum range is 31
3367 bhi L9ACD ; brif out of range
3368 aslb ; adjust back in range
3369 aslb
3370 pshs b ; save new volume
3371 ldd #0x7e7e ; midrange value for both high and low
3372 adda ,s ; add new volume to high limit
3373 subb ,s+ ; subtract volume from low limit
3374 std VOLHI ; save new volume limits (sets high and low amplitudes)
3375 rts
3376 L9A8B cmpa #'L ; note length?
3377 bne L9AB2 ; brif not
3378 ldb NOTELN ; get current length
3379 bsr L9AC0 ; read parameter
3380 tstb ; resulting length 0?
3381 beq L9ACD ; brif so - problem
3382 stb NOTELN ; save new length
3383 clr DOTVAL ; reset note timer scale factor
3384 L9A9A bsr L9A9F ; check for dot
3385 bcc L9A9A ; brif there was one
3386 rts
3387 L9A9F tst VD8 ; check length
3388 beq L9AAD ; brif zero
3389 jsr L9B98 ; get command character
3390 cmpa #'. ; dot?
3391 beq L9AAF ; brif so
3392 jsr L9BE2 ; move input back and bump length
3393 L9AAD coma ; set C to indicate nothing found
3394 rts
3395 L9AAF inc DOTVAL ; bump number of dots
3396 rts
3397 L9AB2 cmpa #'T ; tempo?
3398 bne L9AC3 ; brif not
3399 ldb TEMPO ; get current tempo
3400 bsr L9AC0 ; parse tempo argument
3401 tstb ; 0?
3402 beq L9ACD ; brif so - invalid
3403 stb TEMPO ; save new tempo
3404 rts
3405 L9AC0 jmp L9BAC ; evaluate various operators
3406 L9AC3 cmpa #'P ; pause?
3407 bne L9AEB ; brif not
3408 jsr L9CCB ; evaluate parameter
3409 tstb ; is the pause number 0?
3410 bne L9AD0 ; brif not
3411 L9ACD jmp LB44A ; raise FC error
3412 L9AD0 lda DOTVAL ; save current volume and note scale
3413 ldx VOLHI
3414 pshs x,a
3415 lda #0x7e ; drop DA to mid range
3416 sta VOLHI
3417 sta VOLLOW
3418 clr DOTVAL
3419 bsr L9AE7 ; go play a "silence"
3420 puls a,x ; restore volume and note scale
3421 sta DOTVAL
3422 stx VOLHI
3423 rts
3424 L9AE7 clr ,-s ; set not number 0
3425 bra L9B2B ; go play it
3426 L9AEB cmpa #'N ; N for "note"?
3427 bne L9AF2 ; brif not - it's optional
3428 jsr L9B98 ; skip the "N"
3429 L9AF2 cmpa #'A ; is it a valid note?
3430 blo L9AFA ; brif not
3431 cmpa #'G ; is it above the note range?
3432 bls L9AFF ; brif not - valid note
3433 L9AFA jsr L9BBE ; evaluate a number
3434 bra L9B22 ; process note value
3435 L9AFF suba #'A ; normalize note number to 0
3436 ldx #L9C5B ; point to note number lookup table
3437 ldb a,x ; get not number
3438 tst VD8 ; any command characters left?
3439 beq L9B22 ; brif not
3440 jsr L9B98 ; get character
3441 cmpa #'# ; sharp?
3442 beq L9B15 ; brif so
3443 cmpa #'+ ; also sharp?
3444 bne L9B18 ; brif not
3445 L9B15 incb ; add one half tone
3446 bra L9B22
3447 L9B18 cmpa #'- ; flat?
3448 bne L9B1F ; brif not
3449 decb ; subtract one half tone
3450 bra L9B22
3451 L9B1F jsr L9BE2 ; back up command pointer
3452 L9B22 decb ; adjust note number (zero base it)
3453 cmpb #11 ; is it valid?
3454 bhi L9ACD ; raise error if not
3455 pshs b ; save note value
3456 ldb NOTELN ; get note length
3457 L9B2B lda TEMPO ; get tempo value
3458 mul ; calculate note duration
3459 std VD5 ; save duration
3460 leau 1,s ; point to where the stack goes after we're done
3461 lda OCTAVE ; get current octave
3462 cmpa #1 ; 0 or 1?
3463 bhi L9B64 ; brif not
3464 ldx #L9C62 ; point to delay table
3465 ldb #2*12 ; 24 bytes per octave
3466 mul ; now we have the base address
3467 abx ; now X points to the octave base
3468 puls b ; get back note value
3469 aslb ; two bytes per delay
3470 abx ; now we're pointing to the delay
3471 leay ,x ; save pointer to note value
3472 bsr L9B8C ; calculate note timer value
3473 std PLYTMR ; set timer for note playing (IRQ will count this down)
3474 L9B49 bsr L9B57 ; set to mid range and delay
3475 lda VOLHI ; get high value
3476 bsr L9B5A ; set to high value and delay
3477 bsr L9B57 ; set to mid range and delay
3478 lda VOLLOW ; get low value
3479 bsr L9B5A ; set to low value and delay
3480 bra L9B49 ; do it again (IRQ will break the loop)
3481 L9B57 lda #0x7e ; mid value for DA with RS232 marking
3482 nop ; a delay to fine tune frequencies
3483 L9B5A sta PIA1 ; set DA
3484 ldx ,y ; get delay value
3485 L9B5F leax -1,x ; count down
3486 bne L9B5F ; brif not done yet
3487 rts
3488 L9B64 ldx #L9C92-2*12 ; point to delay table for octaves 2+
3489 ldb #12 ; 12 bytes per octave
3490 mul ; now we have the offset to the desired octave
3491 abx ; now we point to the start of the octave
3492 puls b ; get back note value
3493 abx ; now we point to the delay value
3494 bsr L9B8C ; calculate timer value
3495 std PLYTMR ; set play timer (IRQ counts this down)
3496 L9B72 bsr L9B80 ; send mid value and delay
3497 lda VOLHI ; get high value
3498 bsr L9B83 ; send high value and delay
3499 bsr L9B80 ; send low value and delay
3500 lda VOLLOW ; get low value
3501 bsr L9B83 ; send low value and delay
3502 bra L9B72 ; do it again (IRQ will break the loop)
3503 L9B80 lda #0x7e ; mid range value with RS232 marking
3504 nop ; fine tuning delay
3505 L9B83 sta PIA1 ; set DA
3506 lda ,x ; get delay value
3507 L9B88 deca ; count down
3508 bne L9B88 ; brif not done
3509 rts
3510 L9B8C ldb #0xff ; base timer value
3511 lda DOTVAL ; get number of dots
3512 beq L9B97 ; use default value if 0
3513 adda #2 ; add in constant timer factor
3514 mul ; multiply scale by base
3515 lsra ; divide by two - each increment will increase note timer by 128
3516 rorb
3517 L9B97 rts
3518 L9B98 pshs x ; save register
3519 L9B9A tst VD8 ; do we have anything left?
3520 beq L9BEB ; brif not - raise error
3521 ldx VD9 ; get parsing address
3522 lda ,x+ ; get character
3523 stx VD9 ; save pointer
3524 dec VD8 ; account for character consumed
3525 cmpa #0x20 ; space?
3526 beq L9B9A ; brif so - skip it
3527 puls x,pc ; restore register and return
3528 L9BAC bsr L9B98 ; get character
3529 cmpa #'+ ; add one?
3530 beq L9BEE ; brif so
3531 cmpa #'- ; subtract one?
3532 beq L9BF2 ; brif so
3533 cmpa #'> ; double?
3534 beq L9BFC ; brif so
3535 cmpa #'< ; halve?
3536 beq L9BF7 ; brif so
3537 L9BBE cmpa #'= ; variable equate?
3538 beq L9C01 ; brif so
3539 jsr L90AA ; clear carry if numeric
3540 bcs L9BEB ; brif not numeric
3541 clrb ; initialize value to 0
3542 L9BC8 suba #'0 ; remove ASCII bias
3543 sta VD7 ; save digit
3544 lda #10 ; make room for digit
3545 mul
3546 tsta ; did we overflow 8 bits?
3547 bne L9BEB ; brif so
3548 addb VD7 ; add in digit
3549 bcs L9BEB ; brif that overflowed
3550 tst VD8 ; more digits?
3551 beq L9BF1 ; brif not
3552 jsr L9B98 ; get character
3553 jsr L90AA ; clear carry if numeric
3554 bcc L9BC8 ; brif another digit
3555 L9BE2 inc VD8 ; unaccount for character just read
3556 ldx VD9 ; move pointer back
3557 leax -1,x
3558 stx VD9
3559 rts
3560 L9BEB jmp LB44A ; raise FC error
3561 L9BEE incb ; bump param
3562 beq L9BEB ; brif overflow
3563 L9BF1 rts
3564 L9BF2 tstb ; already zero?
3565 beq L9BEB ; brif so - underflow
3566 decb ; decrease parameter
3567 rts
3568 L9BF7 tstb ; already at 0?
3569 beq L9BEB ; brif so - raise error
3570 lsrb ; halve it
3571 rts
3572 L9BFC tstb ; will it overflow?
3573 bmi L9BEB ; brif so
3574 aslb ; double it
3575 rts
3576 L9C01 pshs u,y ; save registers
3577 bsr L9C1B ; interpret command string as a variable
3578 jsr LB70E ; convert it to an 8 bit number
3579 puls y,u,pc ; restore registers and return
3580 L9C0A jsr L9C1B ; evaluate expression in command string
3581 ldb #2 ; room for 4 bytes?
3582 jsr LAC33
3583 ldb VD8 ; get the command length and pointer
3584 ldx VD9
3585 pshs x,b ; save them
3586 jmp L9A32 ; go process the sub string
3587 L9C1B ldx VD9 ; get command pointer
3588 pshs x ; save it
3589 jsr L9B98 ; get input character
3590 jsr LB3A2 ; set carry if not alpha
3591 bcs L9BEB ; brif not a variable reference
3592 L9C27 jsr L9B98 ; get command character
3593 cmpa #'; ; semicolon?
3594 bne L9C27 ; keep scanning if not
3595 puls x ; get back start of variable string
3596 ldu CHARAD ; get current interpreter input pointer
3597 pshs u ; save it
3598 stx CHARAD ; point interpreter at command string
3599 jsr LB284 ; evaluate expression as string
3600 puls x ; restore interpeter input pointer
3601 stx CHARAD
3602 rts
3603 ; The bit of Extended Basic's IRQ routine that handles PLAY. Note that everything after
3604 ; clr PLYTMR+1 could be replaced with a simple lds 8,s followed by rts.
3605 L9C3E clra ; make sure DP is set to 0
3606 tfr a,dp
3607 ldd PLYTMR ; is PLAY running?
3608 lbeq LA9BB ; brif not - transfer control on the Color Basic's routine
3609 subd VD5 ; subtract out the interval
3610 std PLYTMR ; save new timer value
3611 bhi L9C5A ; brif it isn't <= 0
3612 clr PLYTMR ; disable the timer
3613 clr PLYTMR+1
3614 puls a ; get saved CC
3615 lds 7,s ; set stack to saved U value
3616 anda #0x7f ; clear E flag (to return minimal state)
3617 pshs a ; set fake "FIRQ" stack frame
3618 L9C5A rti
3619 L9C5B fcb 10,12,1,3,5,6,8 ; table of half tone numbers for notes A-G
3620 L9C62 fdb 0x01a8,0x0190,0x017a,0x0164 ; delays for octave 1
3621 fdb 0x0150,0x013d,0x012b,0x011a
3622 fdb 0x010a,0x00fb,0x00ed,0x00df
3623 fdb 0x00d3,0x00c7,0x00bb,0x00b1 ; delays for octave 2
3624 fdb 0x00a6,0x009d,0x0094,0x008b
3625 fdb 0x0083,0x007c,0x0075,0x006e
3626 L9C92 fcb 0xa6,0x9c,0x93,0x8b ; delays for octave 3
3627 fcb 0x83,0x7b,0x74,0x6d
3628 fcb 0x67,0x61,0x5b,0x56
3629 fcb 0x51,0x4c,0x47,0x43 ; delays for octave 4
3630 fcb 0x3f,0x3b,0x37,0x34
3631 fcb 0x31,0x2e,0x2b,0x28
3632 fcb 0x26,0x23,0x21,0x1f ; delays for octave 5
3633 fcb 0x1d,0x1b,0x19,0x18
3634 fcb 0x16,0x14,0x13,0x12
3635 ; DRAW command
3636 DRAW ldx ZERO ; create an empty "DRAW" frame
3637 ldb #1
3638 pshs x,b
3639 stb SETFLG ; set to "PSET" mode
3640 stx VD5 ; clear update and draw flag
3641 jsr L959A ; set active colour byte
3642 jsr LB156 ; evaluate command string
3643 L9CC6 jsr LB654 ; fetch command string details
3644 bra L9CD3 ; interpret the command string
3645 L9CCB jsr L9B98 ; fetch command character
3646 jmp L9BBE ; evaluate a number
3647 L9CD1 puls b,x ; get previously saved command string
3648 L9CD3 stb VD8 ; save length counter
3649 beq L9CD1 ; brif end of string
3650 stx VD9 ; save pointer
3651 lbeq L9DC7 ; brif overall end of command
3652 L9CDD tst VD8 ; are we at the end of the string?
3653 beq L9CD1 ; brif so - return to previous string
3654 jsr L9B98 ; get command character
3655 cmpa #'; ; semicolon?
3656 beq L9CDD ; brif so - ignore it
3657 cmpa #'' ; '?
3658 beq L9CDD ; brif so - ignore that too
3659 cmpa #'N ; update position toggle?
3660 bne L9CF4 ; brif not
3661 com VD5 ; toggle update position flag
3662 bra L9CDD ; get on for another command
3663 L9CF4 cmpa #'B ; blank flag?
3664 bne L9CFC ; brif not
3665 com VD6 ; toggle blank flag
3666 bra L9CDD ; get on for another command
3667 L9CFC cmpa #'X ; substring?
3668 lbeq L9D98 ; brif so - execute command
3669 cmpa #'M ; move draw position?
3670 lbeq L9E32 ; brif so
3671 pshs a ; save command character
3672 ldb #1 ; default value if no number follows
3673 tst VD8 ; is there something there?
3674 beq L9D21 ; brif not
3675 jsr L9B98 ; get character
3676 jsr LB3A2 ; set C if not alpha
3677 pshs cc ; save alpha state
3678 jsr L9BE2 ; move back pointer
3679 puls cc ; get back alpha flag
3680 bcc L9D21 ; brif it's alpha
3681 bsr L9CCB ; evaluate a number
3682 L9D21 puls a ; get command back
3683 cmpa #'C ; color change?
3684 beq L9D4F ; brif so
3685 cmpa #'A ; angle?
3686 beq L9D59 ; brif so
3687 cmpa #'S ; scale?
3688 beq L9D61 ; brif so
3689 cmpa #'U ; up?
3690 beq L9D8F ; brif so
3691 cmpa #'D ; down?
3692 beq L9D8C ; brif so
3693 cmpa #'L ; left?
3694 beq L9D87 ; brif so
3695 cmpa #'R ; right?
3696 beq L9D82 ; brif so
3697 suba #'E ; normalize the half cardinals to 0
3698 beq L9D72 ; brif E (45°)
3699 deca ; F (135°?)
3700 beq L9D6D ; brif so
3701 deca ; G (225°?)
3702 beq L9D7B ; brif so
3703 deca ; H (315°?)
3704 beq L9D69 ; brif so
3705 L9D4C jmp LB44A ; raise FC error
3706 L9D4F jsr L955D ; adjust colour for PMODE
3707 stb FORCOL ; save new foreground colour
3708 jsr L959A ; set up working colour and all pixels byte
3709 L9D57 bra L9CDD ; go process another command
3710 L9D59 cmpb #4 ; only 3 angles are valid
3711 bhs L9D4C ; brif not valid
3712 stb ANGLE ; save new angle
3713 bra L9D57 ; go process another command
3714 L9D61 cmpb #63 ; only 64 scale values are possible
3715 bhs L9D4C ; brif out of range
3716 stb SCALE ; save new scale factor
3717 bra L9D57 ; go process another command
3718 L9D69 clra ; make horizontal negative
3719 bsr L9DC4
3720 skip1
3721 L9D6D clra ; keep horizontal distance positive
3722 tfr d,x ; make horizontal distance and vertical distance the same
3723 bra L9DCB ; go do the draw thing
3724 L9D72 clra ; zero extend horizontal distance
3725 tfr d,x ; set it as vertical
3726 bsr L9DC4 ; negate horizontal distance
3727 exg d,x ; swap directions (vertical is now negative)
3728 bra L9DCB ; go do the draw thing
3729 L9D7B clra ; zero extend horizontal distance
3730 tfr d,x ; copy horizontal to vertical
3731 bsr L9DC4 ; negate horizontal
3732 bra L9DCB ; go do the drawing thing
3733 L9D82 clra ; zero extend horizontal distance
3734 L9DB3 ldx ZERO ; no vertical distance
3735 bra L9DCB ; go do the drawing things
3736 L9D87 clra ; zero extend horizontal
3737 bsr L9DC4 ; negate horizontal
3738 bra L9DB3 ; zero out vertical and do the drawing thing
3739 L9D8C clra ; zero extend distance
3740 bra L9D92 ; make the distance vertical and zero out horizontal
3741 L9D8F clra ; zero extend distance
3742 bsr L9DC4 ; negate distance
3743 L9D92 ldx ZERO ; zero out vertical distance
3744 exg x,d ; swap vertical and horizontal
3745 bra L9DCB ; go do the drawing thing
3746 L9D98 jsr L9C1B ; evaluate substring expression
3747 ldb #2 ; is there enough room for the state?
3748 jsr LAC33
3749 ldb VD8 ; save current command string state
3750 ldx VD9
3751 pshs x,b
3752 jmp L9CC6 ; go evaluate the sub string
3753 L9DA9 ldb SCALE ; get scale factor
3754 beq L9DC8 ; brif zero - default to full size
3755 clra ; zero extend
3756 exg d,x ; put distance somewhere useful
3757 sta ,-s ; save MS of distance
3758 bpl L9DB6 ; brif positive distance
3759 bsr L9DC3 ; negate the distance
3760 L9DB6 jsr L9FB5 ; multiply D and X
3761 tfr u,d ; save ms bytes in D
3762 lsra ; divide by 2
3763 rorb
3764 L9DBD lsra ; ...divide by 4
3765 rorb
3766 tst ,s+ ; negative distance?
3767 bpl L9DC7 ; brif it was positive
3768 L9DC3 nega ; negate D
3769 L9DC4 negb
3770 sbca #0
3771 L9DC7 rts
3772 L9DC8 tfr x,d ; copy unchanged sitance to D
3773 rts
3774 L9DCB pshs b,a ; save horizontal distance
3775 bsr L9DA9 ; apply scale factor to vertical
3776 puls x ; get horizontal distance
3777 pshs b,a ; save scaled vertical
3778 bsr L9DA9 ; apply scale to horizontal
3779 puls x ; get back vertical distance
3780 ldy ANGLE ; get draw angle and scale
3781 pshs y ; save them
3782 L9DDC tst ,s ; is there an angle?
3783 beq L9DE8 ; brif no angle
3784 exg x,d ; swap distances
3785 bsr L9DC3 ; negate D
3786 dec ,s ; account for one tick around the rotation
3787 bra L9DDC ; see if we're there yet
3788 L9DE8 puls y ; get angle and scale back
3789 ldu ZERO ; default end position (horizontal) is 0
3790 addd HORDEF ; add default horizontal to horizontal distance
3791 bmi L9DF2 ; brif we went negative
3792 tfr d,u ; save calculated end coordindate
3793 L9DF2 tfr x,d ; get vertical distance somewhere useful
3794 ldx ZERO ; default vertical end is 0
3795 addd VERDEF ; add distance to default vertical start
3796 bmi L9DFC ; brif negative - use 0
3797 tfr d,x ; save calculated end coordinate
3798 L9DFC cmpu #256 ; is horizontal in range?
3799 blo L9E05 ; brif su
3800 ldu #255 ; maximize it
3801 L9E05 cmpx #192 ; is vertical in range?
3802 blo L9E0D ; brif so
3803 ldx #191 ; maximize it
3804 L9E0D ldd HORDEF ; set starting coordinates for the line
3805 std HORBEG
3806 ldd VERDEF
3807 std VERBEG
3808 stx VEREND ; set end coordinates
3809 stu HOREND
3810 tst VD5 ; are we updating position?
3811 bne L9E21 ; brif not
3812 stx VERDEF ; update default coordinates
3813 stu HORDEF
3814 L9E21 jsr L9420 ; normalize coordindates
3815 tst VD6 ; are we drawing something?
3816 bne L9E2B ; brif not
3817 jsr L94A1 ; draw the line
3818 L9E2B clr VD5 ; reset draw and update flags
3819 clr VD6
3820 jmp L9CDD ; do another command
3821 L9E32 jsr L9B98 ; get a command character
3822 pshs a ; save it
3823 jsr L9E5E ; evaluate horizontal distance
3824 pshs b,a ; save it
3825 jsr L9B98 ; get character
3826 cmpa #', ; comma between coordinates?
3827 lbne L9D4C ; brif not - raise error
3828 jsr L9E5B ; evaluate vertical distance
3829 tfr d,x ; save vertical distance
3830 puls u ; get horizontal distance
3831 puls a ; get back first command character
3832 cmpa #'+ ; was it + at start?
3833 beq L9E56 ; brif +; treat values as positive
3834 cmpa #'- ; was it -?
3835 bne L9DFC ; brif not - treat it as absolute
3836 L9E56 tfr u,d ; put horizontal distance somewhere useful
3837 jmp L9DCB ; move draw position (relative)
3838 L9E5B jsr L9B98 ; get input character
3839 L9E5E cmpa #'+ ; leading +?
3840 beq L9E69 ; brif so
3841 cmpa #'- ; leading -?
3842 beq L9E6A ; brif so - negative
3843 jsr L9BE2 ; move pointer back one
3844 L9E69 clra ; 0 for +, nonzero for -
3845 L9E6A pshs a ; save sign flag
3846 jsr L9CCB ; evaluate number
3847 puls a ; get sign flag
3848 tsta ; negative?
3849 beq L9E78 ; brif not
3850 clra ; zero extend and negate
3851 negb
3852 sbca #0
3853 L9E78 rts
3854 ; Table of sines and cosines for CIRCLE
3855 L9E79 fdb 0x0000,0x0001 ; subarc 0
3856 fdb 0xfec5,0x1919 ; subarc 1
3857 fdb 0xfb16,0x31f2 ; subarc 2
3858 fdb 0xf4fb,0x4a51 ; subarc 3
3859 fdb 0xec84,0x61f9 ; subarc 4
3860 fdb 0xe1c7,0x78ae ; subarc 5
3861 fdb 0xd4dc,0x8e3b ; subarc 6
3862 fdb 0xc5e5,0xa269 ; subarc 7
3863 fdb 0xb506,0xb506 ; subarc 8
3864 ; CIRCLE command
3865 ; The circle is drawn as a 64 sided polygon (64 LINE commands essentially)
3866 CIRCLE cmpa #'@ ; is there an @ before coordinates?
3867 bne L9EA3 ; brif not
3868 jsr GETNCH ; eat the @
3869 L9EA3 jsr L9522 ; get max coordinates for screen
3870 jsr L93B2 ; parse coordinates for circle centre
3871 jsr L931D ; normalize the start coordinates
3872 ldx ,u ; get horizontal coordinate
3873 stx VCB ; save it
3874 ldx 2,u ; get vertical coordinate
3875 stx VCD ; saveit
3876 jsr SYNCOMMA ; make sure we have a comma
3877 jsr LB73D ; evaluate radius expression
3878 ldu #VCF ; point to temp storage
3879 stx ,u ; save radius
3880 jsr L9320 ; normalize radius
3881 lda #1 ; default to PSET
3882 sta SETFLG
3883 jsr L9581 ; evaluate the colour expression
3884 ldx #0x100 ; height/width default value
3885 jsr GETCCH ; is there a ratio?
3886 beq L9EDF ; brif not
3887 jsr SYNCOMMA ; make sure we have a comma
3888 jsr LB141 ; evaluate the ratio
3889 lda FP0EXP ; multiply ratio by 256
3890 adda #8
3891 sta FP0EXP
3892 jsr LB740 ; evaluate ratio to X (fraction part in LSB)
3893 L9EDF lda PMODE ; get graphics mode
3894 bita #2 ; is it even?
3895 beq L9EE9 ; brif so
3896 tfr x,d ; double the ratio
3897 leax d,x
3898 L9EE9 stx VD1 ; save height/width ratio
3899 ldb #1 ; set the SET flag to PSET
3900 stb SETFLG
3901 stb VD8 ; set first time flag (set to 0 after arc drawn)
3902 jsr L9FE2 ; evaluate circle starting point (octant, subarc)
3903 pshs b,a ; save startpoint
3904 jsr L9FE2 ; evaluate circle end point (octant, subarc)
3905 std VD9 ; save endp oint
3906 puls a,b
3907 L9EFD pshs b,a ; save current circle position
3908 ldx HOREND ; move end coordinates to start coordinates
3909 stx HORBEG
3910 ldx VEREND
3911 stx VERBEG
3912 ldu #L9E79+2 ; point to sine/cosine table
3913 anda #1 ; even octant?
3914 beq L9F11 ; brif so
3915 negb ; convert 0-7 to 8-1 for odd octants
3916 addb #8
3917 L9F11 aslb ; four bytes per table entry
3918 aslb
3919 leau b,u ; point to correct table entry
3920 pshs u ; save sine/cosine table entry pointer
3921 jsr L9FA7 ; calculate horizontal offset
3922 puls u ; get back table entry pointer
3923 leau -2,u ; move to cosine entry
3924 pshs x ; save horizontal offset
3925 jsr L9FA7 ; calculate vertical offset
3926 puls y ; put horizontal in Y
3927 lda ,s ; get octant number
3928 anda #3 ; is it 0 or 4?
3929 beq L9F31 ; brif so
3930 cmpa #3 ; is it 3 or 7?
3931 beq L9F31 ; brif so
3932 exg x,y ; swap horizontal and vertical
3933 L9F31 stx HOREND ; save horizontal offset
3934 tfr y,x ; put vertical offset in X
3935 ldd VD1 ; get height/width ratio
3936 jsr L9FB5 ; multiply vertical by h/w ratio
3937 tfr y,d ; save the product to D
3938 tsta ; did it overflow?
3939 lbne LB44A ; brif so
3940 stb VEREND ; save vertical coordinate MSB
3941 tfr u,d ; get LSW of product
3942 sta VEREND+1 ; save LSB of integer part (we have 8 bits of fraction in the ratio)
3943 lda ,s ; get octant
3944 cmpa #2 ; is it 0 or 1?
3945 blo L9F5B ; brif so
3946 cmpa #6 ; is it 6 or 7?
3947 bhs L9F5B ; brif so
3948 ldd VCB ; get horizontal centre
3949 subd HOREND ; subtract horizontal displacement
3950 bcc L9F68 ; brif we didn't overflow the screen
3951 clra ; zero out coordinate if we overflowed the screen
3952 clrb
3953 bra L9F68
3954 L9F5B ldd VCB ; get horizontal coordinate of the centre
3955 addd HOREND ; add displacement
3956 bcs L9F66 ; brif overlod
3957 cmpd VD3 ; larger than max horizontal coord?
3958 blo L9F68 ; brif not
3959 L9F66 ldd VD3 ; maximize the coordinate
3960 L9F68 std HOREND ; save horizontal ending coordainte
3961 lda ,s ; get octant
3962 cmpa #4 ; is it 0-3?
3963 blo L9F7A ; brif so
3964 ldd VCD ; get vertical coordinate of centre
3965 subd VEREND ; subtract displacement
3966 bcc L9F87 ; brif we didn't overflow the screen
3967 clra ; minimize to top of screen
3968 clrb
3969 bra L9F87
3970 L9F7A ldd VCD ; get vertical centre coordinate
3971 addd VEREND ; add displacement
3972 bcs L9F85 ; brif we overflowed the screen
3973 cmpd VD5 ; did we go past max coordinate?
3974 blo L9F87 ; brif not
3975 L9F85 ldd VD5 ; maximize the coordinate
3976 L9F87 std VEREND ; save end coordinate
3977 tst VD8 ; check first time flag
3978 bne L9F8F ; do not draw if first time through (it was setting start coord)
3979 bsr L9FDF ; draw the line
3980 L9F8F puls a,b ; get arc number and sub arc
3981 lsr VD8 ; get first time flag value (and clear it!)
3982 bcs L9F9A ; do not check for end point after drawing for first coordinate
3983 cmpd VD9 ; at end point?
3984 beq L9FA6 ; brif drawing finished
3985 L9F9A incb ; bump arc counter
3986 cmpb #8 ; done 8 arcs?
3987 bne L9FA3 ; brif not
3988 inca ; bump octant
3989 clrb ; reset subarc number
3990 anda #7 ; make sure octant number stays in 0-7 range
3991 L9FA3 jmp L9EFD ; go do another arc
3992 L9FA6 rts
3993 L9FA7 ldx VCF ; get radius
3994 ldd ,u ; get sine/cosine table entry
3995 beq L9FB4 ; brif 0 - offset = radius
3996 subd #1 ; adjust values to correct range
3997 bsr L9FB5 ; multiply radius by sine/cosine
3998 tfr y,x ; resturn result in X
3999 L9FB4 rts
4000 L9FB5 pshs u,y,x,b,a ; save registers and reserve temp space
4001 clr 4,s ; reset overflow byte (YH)
4002 lda 3,s ; calcuate B*XL
4003 mul
4004 std 6,s ; put in "U"
4005 ldd 1,s ; calculate B*XH
4006 mul
4007 addb 6,s ; accumluate with previous product
4008 adca #0
4009 std 5,s ; save in YL,UH
4010 ldb ,s ; calculate A*XL
4011 lda 3,s
4012 mul
4013 addd 5,s ; accumulate with previous partical product
4014 std 5,s ; save in YL,UH
4015 bcc L9FD4 ; brif no carry
4016 inc 4,s ; bump YH for carry
4017 L9FD4 lda ,s ; calculate A*XH
4018 ldb 2,s
4019 mul
4020 addd 4,s ; accumulate with previous partial product
4021 std 4,s ; save in Y (we can't have a carry here)
4022 puls a,b,x,y,u,pc ; restore multiplicands and return results
4023 L9FDF jmp L94A1 ; go draw a line
4024 L9FE2 clrb ; default arc number (0)
4025 jsr GETCCH ; is there something there for a value?
4026 beq L9FF8 ; brif not
4027 jsr SYNCOMMA ; evaluate , + expression
4028 jsr LB141
4029 lda FP0EXP ; multiply by 64
4030 adda #6
4031 sta FP0EXP
4032 jsr LB70E ; get integer value of circle fraction
4033 andb #0x3f ; max value of 63
4034 L9FF8 tfr b,a ; save arc value in A to calculate octant
4035 andb #7 ; calculate subarc
4036 lsra ; calculate octant
4037 lsra
4038 lsra
4039 rts