Mercurial > hg > index.cgi

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