Mercurial > hg > index.cgi

comparison bas11.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 *pragma list
4 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5 ; COLOR BASIC ROM
6 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
7 org BASIC
8 ; This is the official set of ROM entry points. It is unfortunate that the generic input ("console in") routine is not exposed
9 ; here. It is also unfortunate that no open and close file routines are exposed. This and other oversignts led to a lot of
10 ; software either having to re-invent the wheel or calling directly into the ROM instead of via these official entry points.
11 POLCAT fdb KEYIN ; indirect jump, get a keystroke
12 CHROUT fdb PUTCHR ; indirect jump, output character
13 CSRDON fdb CASON ; indirect jump, turn cassette on and start reading
14 BLKIN fdb GETBLK ; indirect jump, read a block from tape
15 BLKOUT fdb SNDBLK ; indirect jump, write a block to tape
16 JOYIN fdb GETJOY ; indirect jump, read joystick axes
17 WRTLDR fdb WRLDR ; indirect jump, turn cassette on and write a leader
18 ; Initialization code.
19 LA00E lds #LINBUF+LBUFMX+1 ; put the stack in the line input buffer which is a safe place for now
20 lda #0x37 ; enable the cartidge interrupt (to detect autostarting cartridges)
21 sta PIA1+3
22 lda RSTFLG ; get warm start flag
23 cmpa #0x55 ; is it valid?
24 bne BACDST ; brif not - cold start
25 ldx RSTVEC ; get warm start routine pointer
26 lda ,x ; get first byte of the routine
27 cmpa #0x12 ; is it NOP?
28 bne BACDST ; brif not - the routine is invalid so do a cold start
29 jmp ,x ; transfer control to the warm start routine
30 ; RESET/power on comes here
31 RESVEC leay LA00E,pcr ; point to warm start check code
32 LA02A ldx #PIA1 ; point to PIA1 - we're going to rely on the mirroring to reach PIA0
33 clr -3,x ; set PIA0 DA to direction mode
34 clr -1,x ; set PIA0 DB to direction mode
35 clr -4,x ; set PIA0 DA to inputs
36 ldd #0xff34
37 sta -2,x ; set PIA0 DB to outputs
38 stb -3,x ; set PIA0 DA to data mode
39 stb -1,x ; set PIA0 DB to data mode
40 clr 1,x ; set PIA1 DA to direction mode
41 clr 3,x ; set PIA1 DB to direction mode
42 deca
43 sta ,x ; set PIA1 DA bits 7-1 as output, 0 as input
44 lda #0xf8 ; set PIA1 DB bits 7-3 as output, 2-0 as input
45 sta 2,x
46 stb 1,x ; set PIA1 DA to data mode
47 stb 3,x ; set PIA1 DB to data mode
48 clr 2,x ; set VDG to alpha-numeric
49 ldb #2 ; make RS232 marking ("stop" bit)
50 stb ,x
51 ldu #SAMREG ; point to SAM register
52 ldb #16 ; 16 bits to clear
53 LA056 sta ,u++ ; clear a bit
54 decb ; done all?
55 bne LA056 ; brif not
56 sta SAMREG+9 ; put display at 0x400
57 tfr b,dp ; set direct page to 0
58 ldb #4 ; use as a mask to check RAMSZ input
59 sta -2,x ; set RAMSZ strobe high
60 bitb 2,x ; check RAMSZ input
61 beq LA072 ; brif set for 4K RAMs
62 clr -2,x ; set strobe low
63 bitb 2,x ; check input
64 beq LA070 ; brif set for 64K rams
65 leau -2,u ; adjust pointer to set SAM for 16K RAMs
66 LA070 sta -3,u ; program SAM for either 16K or 64K RAMs
67 LA072 jmp ,y ; transfer control to startup routine
68 ; Cold start jumps here
69 BACDST ldx #VIDRAM+1 ; point past the top of the first 1K of memory (for double predec below)
70 LA077 clr ,--x ; clear a byte (last will actually try clearing LSB of RESET vector in ROM)
71 leax 1,x ; move forward one byte (will set Z if we're done)
72 bne LA077 ; brif not donw yet
73 jsr LA928 ; clear the screen
74 clr ,x+ ; put the constant zero that lives before the program
75 stx TXTTAB ; set beginning of program storage
76 LA084 lda 2,x ; get value from memory
77 coma ; make it different
78 sta 2,x ; try putting different into memory
79 cmpa 2,x ; did it matcH?
80 bne LA093 ; brif not - we found the end of memory
81 leax 1,x ; move pointer forward
82 com 1,x ; restore the original memory contents
83 bra LA084 ; try another byte
84 LA093 stx TOPRAM ; save top of memory (one below actual top because we need a byte for VAL() to work)
85 stx MEMSIZ ; save top of string space
86 stx STRTAB ; set bottom of allocated string space
87 leax -200,x ; allocate 200 bytes of string space
88 stx FRETOP ; set top of actually free memory
89 tfr x,s ; put the stack there
90 ldx #LA10D ; point to variable initializer
91 ldu #CMPMID ; point to variables to initialize (first batch)
92 ldb #28 ; 28 bytes in first batch
93 jsr LA59A ; copy bytes to variables
94 ldu #IRQVEC ; point to variables to initialize (second batch)
95 ldb #30 ; 30 bytes this time
96 jsr LA59A ; copy bytes to variables
97 ldx -12,x ; get SN error address
98 stx 3,u ; set ECB's command handlers to error
99 stx 8,u
100 ldx #RVEC0 ; point to RAM vectors
101 ldd #0x394b ; write 75 RTS opcodes (25 RAM vectors)
102 LA0C0 sta ,x+ ; put an RTS
103 decb ; done?
104 bne LA0C0 ; brif not
105 sta LINHDR-1 ; make temporary line header data for line encoding have a nonzero next line pointer
106 jsr LAD19 ; do a "NEW"
107 ldx #'E*256+'X ; magic number to detect ECB ROM
108 cmpx EXBAS ; is there an ECB ROM?
109 lbeq EXBAS+2 ; brif so - launch it
110 andcc #0xaf ; start interrupts
111 ldx #LA147-1 ; point to sign on message
112 jsr LB99C ; print it out
113 ldx #BAWMST ; warm start routine address
114 stx RSTVEC ; set vector there
115 lda #0x55 ; warm start valid flag
116 sta RSTFLG ; mark warm start valid
117 bra LA0F3 ; go to direct mode
118 ; Warm start entry point
119 BAWMST nop ; valid routine marker
120 clr DEVNUM ; reset output/input to screen
121 jsr LAD33 ; do a partial NEW
122 andcc #0xaf ; start interrupts
123 jsr LA928 ; clear the screen
124 LA0F3 jmp LAC73 ; go to direct mode
125 ; FIRQ service routine - this handles starting autostart cartridges
126 BFRQSV tst PIA1+3 ; is it the cartridge interrupt?
127 bmi LA0FC ; brif so
128 rti
129 LA0FC jsr LA7D1 ; delay for a while
130 jsr LA7D1 ; delay for another while
131 leay <LA108,pcr ; point to cartridge starter
132 jmp LA02A ; go initialize everything clean for the cartridge
133 LA108 clr RSTFLG ; force a cold start a cartridge reset
134 jmp ROMPAK ; transfer control to the cartridge
135 ; Variable initializers (first batch)
136 LA10D fcb 18 ; mid band partition of the 1200/2400 Hz period
137 fcb 24 ; upper limit of 1200 Hz period
138 fcb 10 ; upper limit of 2400 Hz period
139 fdb 128 ; number of 0x55s for cassette leader
140 fcb 11 ; cursor blink delay
141 fdb 87 ; 600 baud delay constant
142 fdb 1 ; printer carriage return delay constant
143 fcb 16 ; printer tab field width
144 fcb 112 ; last printer tab zone
145 fcb 132 ; printer carriage width
146 fcb 0 ; printer carriage position
147 fdb LB44A ; default execution address for EXEC
148 inc CHARAD+1 ;* character fetching routines (DP portion) - we first do a two
149 bne LA123 ;* two stage increment of CHARAD then load the value into A
150 inc CHARAD ;* before transferring control to the bottom half routine in ROM
151 LA123 lda >0 ; NOTE: the 0 is a placeholder, extended addressing is required
152 jmp BROMHK
153 ; Variable initializers (second batch)
154 jmp BIRQSV ; IRQ handler
155 jmp BFRQSV ; FIRQ handler
156 jmp LB44A ; default USR() address
157 fcb 0x80,0x4f,0xc7,0x52,0x59 ; random seed
158 fcb 0xff ; capslock flag - default to upper case
159 fdb DEBDEL ; keyboard debounce delay (why is it a variable?)
160 jmp LB277 ; exponentiation handler vector
161 fcb 53 ; (command interpretation table) 53 commands
162 fdb LAA66 ; (command interpretation table) reserved words list (commands)
163 fdb LAB67 ; (command interpretation table) jump table (commands)
164 fcb 20 ; (command interpretation table) 20 functions
165 fdb LAB1A ; (command interpretation table) reserved words list (functions)
166 fdb LAA29 ; (command interpretation table) jump table (functions)
167 ; This is the signon message.
168 LA147 fcc 'COLOR BASIC 1.1'
169 fcb 0x0d
170 fcc '(C) 1980 TANDY'
171 fcb 0
172 ; This is the "invalid colour" CLS easter egg text. Basically 11 wasted bytes
173 LA166 fcc 'MICROSOFT'
174 fcb 0x0d,0
175 ; Read a character from current device and mask off bit 7 (keep it as 7 bit ASCII)
176 LA171 bsr LA176 ; get character
177 anda #0x7f ; mask off high bit
178 rts
179 ; Generic read routine. Reads a character from the device specified by DEVNUM. If no input was available,
180 ; CINBFL will bet nonzero (on EOF). If input was available, CINBFL will be zero. Note that this routine
181 ; has undefined results when called on an output only device. All registers except CC and A are preserved.
182 LA176 jsr RVEC4 ; do RAM hook
183 clr CINBFL ; flag data available
184 tst DEVNUM ; is it keyboard?
185 beq LA1B1 ; brif so - blink cursor and wait for key press
186 tst CINCTR ; is there anything in cassette input buffer?
187 bne LA186 ; brif so
188 com CINBFL ; flag EOF
189 rts
190 ; Read character from cassette file
191 LA186 pshs u,y,x,b ; preserve registers
192 ldx CINPTR ; get input buffer pointer
193 lda ,x+ ; get character from buffer
194 pshs a ; save it for return
195 stx CINPTR ; save new input buffer pointer
196 dec CINCTR ; count character just consumed
197 bne LA197 ; brif buffer is not empty yet
198 jsr LA635 ; go read another block, if any, to refill the buffer
199 LA197 puls a,b,x,y,u,pc ; restore registers and return the character
200 ; Blink the cursor. This might be better timed via an interrupt or something.
201 LA199 dec BLKCNT ; is it time to blink the cursor?
202 bne LA1AB ; brif not
203 ldb #11 ; reset blink timer
204 stb BLKCNT
205 ldx CURPOS ; get cursor position
206 lda ,x ; get character at the cursor
207 adda #0x10 ; move to next color
208 ora #0x8f ; make sure it's a grahpics block with all elements lit
209 sta ,x ; put new cursor block on screen
210 LA1AB ldx #DEBDEL ; we'll use the debounce delay for the cursor blink timer (10ms)
211 LA1AE jmp LA7D3 ; go count X down
212 ; Blink cursor while waiting for a key press
213 LA1B1 pshs x,b ; save registers
214 LA1B3 bsr LA199 ; go do a cursor iteration
215 bsr KEYIN ; go read a key
216 beq LA1B3 ; brif no key pressed
217 ldb #0x60 ; VDG screen space character
218 stb [CURPOS] ; blank cursor out
219 LA1BF puls b,x,pc ; restore registers and return
220 ; This is the actual keyboard polling routine. Returns 0 if no new key is down. Updated compared to 1.0 to reject
221 ; joystick buttons.
222 KEYIN pshs u,x,b ; save registers
223 bsr LA1C8 ; get keystroke
224 tsta ; set flags
225 puls b,x,u,pc ; restore registers and return
226 LA1C8 ldu #PIA0 ; point to keyboard PIA
227 ldx #KEYBUF ; point to state table
228 clra ; clear carry and set column strobe and counter to 0xff
229 deca
230 pshs x,a ; save colomn counter and a couple of holes for temporaries
231 sta 2,u ; initialize the column strobe to no columns active
232 skip1
233 LA1D5 comb ; set carry flag
234 rol 2,u ; move to nextcolumn
235 bcc LA1BF ; brif we've done the last one
236 inc 0,s ; bump column count
237 bsr LA239 ; read keyboard row data
238 sta 1,s ; save key data
239 eora ,x ; set any bit where a key state changed
240 anda ,x ; ignore any where a key was released
241 ldb 1,s ; get new key data
242 stb ,x+ ; save in state table
243 tsta ; was a key down?
244 beq LA1D5 ; brif not - check another
245 ldb 2,u ; get column strobe data
246 stb 2,s ; save it for later
247 ldb #0xf8 ; make sure B is 0 after first ADDB
248 LA1F1 addb #8 ; adjust to next row
249 lsra ; are we at the right row base?
250 bcc LA1F1 ; brif not
251 addb 0,s ; add in column number
252 beq LA244 ; brif it was @
253 cmpb #26 ; letter?
254 bhi LA246 ; brif not
255 orb #0x40 ; add in upper case ASCII bias
256 bsr LA22E ; check for shift key
257 beq LA20B ; brif shift down
258 lda CASFLG ; check casplock
259 bne LA20B ; brif not caps mode
260 orb #0x20 ; convert to lower case
261 LA20B stb 0,s ; temp store ASCII value
262 ldx DEBVAL ; get debounce dely counter
263 jsr LA7D3 ; wait while we count X down
264 ldb #0xff ; set column strobe to no columns
265 bsr LA237 ; read keyboard data
266 inca ; do we have anything reading?
267 bne LA220 ; brif so - reject keyboard read
268 LA21A ldb 2,s ; get saved column strobe
269 bsr LA237 ; read the keyboard data
270 cmpa 1,s ; does it match the result before the delay?
271 LA220 puls a ; get back return value
272 bne LA22B ; brif we have a non-match or joystick button
273 cmpa #0x12 ; SHIFT-0?
274 bne LA22C ; brif not
275 com CASFLG ; swap capslock state
276 LA22B clra ; set Z and return zero for no key down
277 LA22C puls x,pc ; restore registers and return
278 LA22E lda #0x7f ; column strobe for SHIFT
279 sta 2,u ; strobe keyboard
280 lda ,u ; get row data
281 anda #0x40 ; only keep shift state
282 rts
283 LA237 stb 2,u ; save requested column strobe
284 LA239 lda ,u ; read row data
285 ora #0x80 ; mask joystick comparator input
286 tst 2,u ; are we reading column 7?
287 bmi LA243 ; brif not
288 ora #0xc0 ; also mask off the SHIFT key
289 LA243 rts
290 LA244 ldb #51 ; scan code for @
291 LA246 ldx #CONTAB-0x36 ; point to first batch in control code list
292 cmpb #33 ; arrows, space, zero?
293 blo LA263 ; brif so
294 ldx #CONTAB-0x54 ; point to second batch in control code list
295 cmpb #48 ; ENTER, CLEAR, BREAK, @?
296 bhs LA263 ; brif so
297 bsr LA22E ; get shift status
298 cmpb #43 ; number, colon, semicolon?
299 bls LA25C ; brif so
300 eora #0x40 ; invert shift sense if so
301 LA25C tsta ; test shift status
302 beq LA20B ; brif shift down - we have the code so check for debounce
303 addb #0x10 ; add in ASCII offset
304 bra LA20B ; check for debounce
305 LA263 aslb ; two entries for table entry
306 bsr LA22E ; get shift status
307 bne LA269 ; brif not down
308 incb ; move to shifted code entry
309 LA269 ldb b,x ; get ASCII code
310 bra LA20B ; go check for debounce
311 fcb 0 ; unused in Color Basic 1.0
312 CONTAB fcb 0x5e,0x5f ; <UP> (^, _)
313 fcb 0x0a,0x5b ; <DOWN> (LF, [)
314 fcb 0x08,0x15 ; <LEFT> (BS, ^U)
315 fcb 0x09,0x5d ; <RIGHT> (TAB, ])
316 fcb 0x20,0x20 ; <SPACE>
317 fcb 0x30,0x12 ; <0> (0, ^R)
318 fcb 0x0d,0x0d ; <ENTER> (CR, CR)
319 fcb 0x0c,0x5c ; <CLEAR> (FF, \)
320 fcb 0x03,0x03 ; <BREAK> (^C, ^C)
321 fcb 0x40,0x13 ; <@> (@, ^S)
322 ; Generic output routine.
323 ; Output character in A to the device specified by DEVNUM. All registers are preserved except CC.
324 ; Sending output to a device that does not support output is undefined.
325 PUTCHR jsr RVEC3 ; call RAM hook
326 pshs b ; save B
327 ldb DEVNUM ; get desired device number
328 incb ; set flags (Z for -1, etc.)
329 puls b ; restore B
330 bmi LA2BF ; brif < -1 (line printer)
331 bne LA30A ; brif > -1 (screen)
332 ; Write character to tape file
333 pshs x,b,a ; save registers
334 ldb FILSTA ; get file status
335 decb ; input file?
336 beq LA2A6 ; brif so
337 ldb CINCTR ; get character count
338 incb ; account for this character
339 bne LA29E ; brif buffer not full
340 bsr LA2A8 ; write previously full block to tape
341 LA29E ldx CINPTR ; get output buffer pointer
342 sta ,x+ ; put character in output
343 stx CINPTR ; save new buffer pointer
344 inc CINCTR ; account for this character
345 LA2A6 puls a,b,x,pc ; restore registers and return
346 ; Write a block of data to tape.
347 LA2A8 ldb #1 ; data block type
348 LA2AA stb BLKTYP ; set block type
349 ldx #CASBUF ; point to output buffer
350 stx CBUFAD ; set buffer pointer
351 ldb CINCTR ; get number of bytes in the block
352 stb BLKLEN ; set length to write
353 pshs u,y,a ; save registers
354 jsr LA7E5 ; write a block to tape
355 puls a,y,u ; restore registers
356 jmp LA650 ; reset buffer pointers
357 LA2BF pshs x,b,a,cc ; save registers and interrupt status
358 orcc #0x50 ; disable interrupts
359 bsr LA2FB ; set output to marking
360 clrb ; transmit a start bit
361 bsr LA2FD
362 ldb #8 ; send 8 bits
363 LA2CA pshs b ; save bit counter
364 clrb ; set output to
365 lsra ; get output bit to C
366 rolb ; get it to the correct bit position for output
367 aslb
368 bsr LA2FD ; send the bit
369 puls b ; get back bit counter
370 decb ; sent all 8 bits?
371 bne LA2CA ; brif not
372 bsr LA2FB ; send stop bit (B is 0)
373 puls cc,a ; restore interrupts and output character
374 cmpa #0x0d ; carriage return?
375 beq LA2E7 ; brif so
376 inc LPTPOS ; bump printer position
377 ldb LPTPOS ; get current printer position
378 cmpb LPTWID ; end of line?
379 blo LA2ED ; brif not
380 LA2E7 clr LPTPOS ; reset to start of line
381 bsr LA305 ; delay for carriage return
382 bsr LA305
383 LA2ED ldb PIA1+2 ; get rs232 status
384 lsrb ; is it "read"?
385 bcs LA2ED ; brif not
386 puls b,x,pc ; restore registers and return
387 fdb 0,0,0 ; unused space
388 LA2FB ldb #2 ; set output to high (marking)
389 LA2FD stb PIA1 ; set RS232 output
390 bsr LA302 ; do baud delay (first iteration) then fall through for second
391 LA302 ldx LPTBTD ; get buard rate delay constant
392 skip2
393 LA305 ldx LPTLND ; get carriage return delay constant
394 jmp LA7D3 ; count X down
395 ; Output character to screen
396 LA30A pshs x,b,a ; save registers
397 ldx CURPOS ; get cursor pointer
398 cmpa #0x08 ; backspace?
399 bne LA31D ; brif not
400 cmpx #VIDRAM ; at top of screen?
401 beq LA35D ; brif so - it's a no-op
402 lda #0x60 ; VDG space character
403 sta ,-x ; put a space at previous location and move pointer back
404 bra LA344 ; save new cursor position and return
405 LA31D cmpa #0x0d ; carriage return?
406 bne LA32F ; brif not
407 ldx CURPOS ; get cursor pointer (why? we already have it)
408 LA323 lda #0x60 ; VDG space character
409 sta ,x+ ; put output space
410 tfr x,d ; see if we at a multiple of 32 now
411 bitb #0x1f
412 bne LA323 ; brif not
413 bra LA344 ; go check for scrolling
414 LA32F cmpa #0x20 ; control character?
415 blo LA35D ; brif so
416 tsta ; is it graphics block?
417 bmi LA342 ; brif so
418 cmpa #0x40 ; number or special?
419 blo LA340 ; brif so (flip "case" bit)
420 cmpa #0x60 ; upper case alpha?
421 blo LA342 ; brif so - keep it unmodified
422 anda #0xdf ; clear bit 5 (inverse video)
423 LA340 eora #0x40 ; flip inverse video bit
424 LA342 sta ,x+ ; output character
425 LA344 stx CURPOS ; save new cursor position
426 cmpx #VIDRAM+511 ; end of screen?
427 bls LA35D ; brif not
428 ldx #VIDRAM ; point to start of screen
429 LA34E ldd 32,x ; get two characters from next row
430 std ,x++ ; put them on this row
431 cmpx #VIDRAM+0x1e0 ; at start of last row on screen?
432 blo LA34E ; brif not
433 ldb #0x60 ; VDG space
434 jsr LA92D ; blank out last line (borrow CLS's loop)
435 LA35D puls a,b,x,pc ; restore registers and return
436 ; Set up device parameters for output
437 LA35F jsr RVEC2 ; do the RAM hook dance
438 pshs x,b,a ; save registers
439 clr PRTDEV ; flag device as a screen
440 lda DEVNUM ; get devicenumber
441 beq LA373 ; brif screen
442 inca ; is it tape?
443 beq LA384 ; brif so
444 ldx LPTCFW ; get tab width and last tab stop for printer
445 ldd LPTWID ; get line width and current position for printer
446 bra LA37C ; set parameters
447 LA373 ldb CURPOS+1 ; get LSB of cursor position
448 andb #0x1f ; now we have the offset into the line
449 ldx #0x1010 ; 16 character tab, position 16 is last tab stop
450 lda #32 ; screen is 32 characters wide
451 LA37C stx DEVCFW ; save tab width and last tab stop for active device
452 stb DEVPOS ; save line position for current device
453 sta DEVWID ; save line width for current device
454 puls a,b,x,pc ; restore registers and return
455 LA384 com PRTDEV ; flag device as non-display
456 ldx #0x0100 ; tab width is 1, last tab field is 0
457 clra ; line width is 0
458 clrb ; character position on line is 0
459 bra LA37C ; go set parameters
460 ; This is the line input routine used for reading lines for Basic, both in immediate mode and for
461 ; INPUT and LINE INPUT. Exit with C set if terminated by BREAK and C clear if terminated by ENTER.
462 ; The actualy entry point is LA390. Note that this routine echoes to *all* devices.
463 LA38D jsr LA928 ; clear screen (CLEAR key handling)
464 LA390 jsr RVEC12 ; do the RAM hook dance
465 clr IKEYIM ; reset cached input character from BREAK check
466 ldx #LINBUF+1 ; point to line input buffer (input pointer)
467 ldb #1 ; Number of characters in line (we start at 1 so BS handling is easier)
468 LA39A jsr LA171 ; get an input character, only keep low 7 bits
469 tst CINBFL ; is it EOF?
470 bne LA3CC ; brif EOF
471 tst DEVNUM ; is it keyboard input?
472 bne LA3C8 ; brif not - don't do line editing
473 cmpa #0x0c ; form feed (CLEAR)?
474 beq LA38D ; brif so - clear screen and reset
475 cmpa #0x08 ; backspace?
476 bne LA3B4 ; brif not
477 decb ; move back one character
478 beq LA390 ; brif we were at the start of the line - reset and start again
479 leax -1,x ; move input pointer back
480 bra LA3E8 ; echo the backspace and continue
481 LA3B4 cmpa #0x15 ; SHIFT-LEFT (kill line)?
482 bne LA3C2 ; brif not
483 LA3B8 decb ; at start of line?
484 beq LA390 ; brif so - reset and restart
485 lda #0x08 ; echo a backspace
486 jsr PUTCHR
487 bra LA3B8 ; see if we've erased everything yet
488 LA3C2 cmpa #0x03 ; BREAK?
489 orcc #1 ; set C if it is (only need Z for the next test
490 beq LA3CD ; brif BREAK - exit
491 LA3C8 cmpa #0x0d ; ENTER (CR)
492 bne LA3D9 ; brif not
493 LA3CC clra ; clear carry (it might not be clear on EOF)
494 LA3CD pshs cc ; save ENTER/BREAK flag
495 jsr LB958 ; echo a carriage return
496 clr ,x ; make sure we have a NUL at the end of the buffer
497 ldx #LINBUF ; point to input buffer
498 puls cc,pc ; restore ENTER/BREAK flag and return
499 LA3D9 cmpa #0x20 ; control character?
500 blo LA39A ; brif so - skip it
501 cmpa #'z+1 ; above z?
502 bhs LA39A ; brif so - ignore it
503 cmpb #LBUFMX ; is the buffer full?
504 bhs LA39A ; brif so - ignore extra characters
505 sta ,x+ ; put character in the buffer
506 incb ; bump character count
507 LA3E8 jsr PUTCHR ; echo character
508 bra LA39A ; go handle next input character
509 ; Check if DEVNUM Is valid for reading. Raise FM error if open but not for reading. NO error if not open.
510 LA3ED jsr RVEC5 ; do the RAM hook dance
511 lda DEVNUM ; get device number
512 beq LA415 ; brif keyboard - always valid
513 inca ; is it tape?
514 bne LA403 ; brif not
515 lda FILSTA ; get tape file status
516 bne LA400 ; brif file is open
517 LA3FB ldb #22*2 ; raise NO error
518 jmp LAC46
519 LA400 deca ; is it in input mode?
520 beq LA415 ; brif so
521 LA403 jmp LA616 ; raise FM error
522 ; Check if DEVNUM is valid for writing. Raise FM error if open but not for writing. NO error if not open.
523 LA406 jsr RVEC6 ; do the RAM hook dance
524 lda DEVNUM ; get device number
525 inca ; is it tape?
526 bne LA415 ; brif not
527 lda FILSTA ; get file status
528 beq LA3FB ; brif not open
529 deca ; is it open for reading?
530 beq LA403 ; brif so - bad mode
531 LA415 rts
532 ; CLOSE command
533 CLOSE beq LA426 ; brif no file specified - close all files
534 jsr LA5A5 ; parse device number
535 LA41B bsr LA42D ; close specified file
536 jsr GETCCH ; is there more?
537 beq LA44B ; brif not
538 jsr LA5A2 ; check for comma and parse another device number
539 bra LA41B ; go close this one
540 ; Close all files handler.
541 LA426 jsr RVEC7 ; Yup. The RAM hook dance.
542 lda #-1 ; start with tape file
543 sta DEVNUM
544 ; Close file specified in DEVNUM. Note that this never fails.
545 LA42D jsr RVEC8 ; You know it. RAM hook.
546 lda DEVNUM ; get device we're closing
547 clr DEVNUM ; reset to screen/keyboard
548 inca ; is it tape?
549 bne LA44B ; brif not
550 lda FILSTA ; get file status
551 cmpa #2 ; is it output?
552 bne LA449 ; brif not
553 lda CINCTR ; is there anything waiting to be written?
554 beq LA444 ; brif not
555 jsr LA2A8 ; write final block of data
556 LA444 ldb #0xff ; write EOF block
557 jsr LA2AA
558 LA449 clr FILSTA ; mark tape file closed
559 LA44B rts
560 ; CSAVE command
561 CSAVE jsr LA578 ; parse filename
562 jsr GETCCH ; see what we have after the file name
563 beq LA469 ; brif none
564 jsr LB26D ; make sure there's a comma
565 ldb #'A ; make sure there's an A after
566 jsr LB26F
567 bne LA44B ; brif not end of line
568 clra ; file type 0 (basic program)
569 jsr LA65C ; write out header block
570 lda #-1 ; set output to tape
571 sta DEVNUM
572 clra ; set Z so we list the whole program
573 jmp LIST ; go list the program to tape
574 LA469 clra ; file type 0 (basic program)
575 ldx ZERO ; set to binary file mode
576 jsr LA65F ; write header block
577 clr FILSTA ; close files
578 inc BLKTYP ; set block type to data
579 jsr WRLDR ; write out a leader
580 ldx TXTTAB ; point to start of program
581 LA478 stx CBUFAD ; set buffer location
582 lda #255 ; block size to 255 bytes (max size)
583 sta BLKLEN
584 ldd VARTAB ; get end of program
585 subd CBUFAD ; how much is left?
586 beq LA491 ; brif we have nothing left
587 cmpd #255 ; do we have a full block worth?
588 bhs LA48C ; brif so
589 stb BLKLEN ; save actual remainder as block length
590 LA48C jsr SNDBLK ; write a block out
591 bra LA478 ; go do another block
592 LA491 neg BLKTYP ; set block type to 0xff (EOF)
593 clr BLKLEN ; no data in EOF block
594 jmp LA7E7 ; write EOF, stop tape, and return
595 ; CLOAD and CLOADM commands
596 CLOAD clr FILSTA ; close tape file
597 cmpa #'M ; is it ClOADM?
598 beq LA4FE ; brif so
599 leas 2,s ; clean up stack
600 jsr LA5C5 ; parse file name
601 jsr LA648 ; go find the file
602 tst CASBUF+10 ; is it binary?
603 beq LA4C8 ; brif so
604 lda CASBUF+9 ; is it ASCII?
605 beq LA4CD ; brif not
606 jsr LAD19 ; clear out existing program
607 lda #-1 ; set up for reading from tape
608 sta DEVNUM
609 inc FILSTA ; set tape file to input
610 jsr LA635 ; go read first block
611 jmp LAC7C ; go to immediate mode to read in the program
612 ; This is the EOF handler for immediate mode. It's rather assinine for this to be located here. It is
613 ; probably an artifact of a substantially different code layout prior to compacting the ROM to fit in
614 ; 8K.
615 LA4BF jsr RVEC13 ; do the RAM hook dance
616 jsr LA42D ; close file
617 jmp LAC73 ; go back to immediate mode
618 LA4C8 lda CASBUF+8 ; get file type
619 beq LA4D0 ; brif basic program
620 LA4CD jmp LA616 ; raise FM error
621 LA4D0 jsr LAD19 ; erase existing program
622 jsr CASON ; start reading tape
623 ldx TXTTAB ; get start of program storage
624 LA4D8 stx CBUFAD ; set load address for block
625 ldd CBUFAD ; get start of block
626 inca ; bump by 256
627 jsr LAC37 ; check if there's room for a maximum sized block of 255
628 jsr GETBLK ; go read a block
629 bne LA4F8 ; brif there was an error during reading
630 lda BLKTYP ; get type of block read
631 beq LA4F8 ; brif header block - IO error
632 bpl LA4D8 ; brif data block - read another
633 stx VARTAB ; save new end of program
634 bsr LA53B ; stop tape
635 ldx #LABED-1 ; point to "OK" prompt
636 jsr LB99C ; show prompt
637 jmp LACE9 ; reset various things and return
638 LA4F8 jsr LAD19 ; clear out partial program load
639 LA4FB jmp LA619 ; raise IO error
640 ; This is the CLOADM command
641 LA4FE jsr GETNCH ; eat the "M"
642 bsr LA578 ; parse file name
643 jsr LA648 ; go find the file
644 LA505 ldx ZERO ; default offset is 0
645 jsr GETCCH ; see if there's something after the file name
646 beq LA511 ; brif no offset
647 jsr LB26D ; make sure there's a comma
648 jsr LB73D ; evaluate offset to X
649 LA511 lda CASBUF+8 ; get file mode
650 cmpa #2 ; M/L program?
651 bne LA4CD ; brif not - FM error
652 ldd CASBUF+11 ; get load address
653 leau D,x ; add in offset
654 stu EXECJP ; set EXEC default address
655 tst CASBUF+10 ; is it binary?
656 bne LA4CD ; brif not
657 ldd CASBUF+13 ; get load address
658 leax d,x ; add in offset
659 stx CBUFAD ; set buffer address for loading
660 jsr CASON ; start up tape
661 LA52E jsr GETBLK ; read a block
662 bne LA4FB ; brif error reading
663 stx CBUFAD ; save new load address
664 tst BLKTYP ; set flags on block type
665 beq LA4FB ; brif another header - IO error
666 bpl LA52E ; brif it was data - read more
667 LA53B jmp LA7E9 ; turn off tape and return
668 ; The EXEC command
669 EXEC beq LA545 ; brif no argument - use default address
670 jsr LB73D ; evaluate EXEC address to X
671 stx EXECJP ; set new default EXEC address
672 LA545 jmp [EXECJP] ; transfer control to execution address
673 ; Break check for LIST so it doesn't interrupt ASCII saves. Why is this here instead of with the rest of the break
674 ; check logic or packaged up with LIST?
675 LA549 jsr RVEC11 ; do the RAM hook dance
676 lda DEVNUM ; get device number
677 inca ; is it tape?
678 beq LA5A1 ; brif so - don't do break check
679 jmp LADEB ; do the actual break check
680 ; Evaluate an expression and make sure it is within the limits of the screen and sets the cursor position.
681 ; This really should be located with the PRINT command.
682 LA554 jsr LB3E4 ; evaluate a positive expression to D
683 subd #511 ; is it within bounds?
684 lbhi LB44A ; brif not - error out
685 addd #VIDRAM+511 ; adjust to be within the screen (and undo the SUBD above)
686 std CURPOS ; set cursor position
687 rts
688 ; INKEY$ function
689 INKEY lda IKEYIM ; was a key down during break check?
690 bne LA56B ; brif so
691 jsr KEYIN ; poll the keyboard
692 LA56B clr IKEYIM ; reset the break check cache
693 sta FPA0+3 ; store result for later return
694 lbne LB68F ; brif a key was down - return it as a string
695 sta STRDES ; set string length to 0 (no key down)
696 jmp LB69B ; return the NULL string
697 ; Parse a filename
698 LA578 ldx #CFNBUF ; point to file name buffer
699 clr ,x+ ; zero out file name length
700 lda #0x20 ; space character to initialize file name
701 LA57F sta ,x+ ; put a space in the buffer
702 cmpx #CASBUF ; at end of file name?
703 bne LA57F ; brif not
704 jsr GETCCH ; get input character
705 beq LA5A1 ; brif no name present
706 jsr LB156 ; evaluate the file name expression
707 jsr LB654 ; point to start of the file name
708 ldu #CFNBUF ; point to file name buffer
709 stb ,u+ ; save string length
710 beq LA5A1 ; brif empty - we're done
711 skip2
712 LA598 ldb #8 ; copy 8 bytes
713 ; Move B bytes from (X) to (U)
714 LA59A lda ,x+ ; copy a byte
715 sta ,u+
716 decb ; done yet?
717 bne LA59A ; brif not
718 LA5A1 rts
719 ; Parse a device number and check validity
720 LA5A2 jsr LB26D ; check for comma and SN error if not
721 LA5A5 cmpa #'# ; do we have a #?
722 bne LA5AB ; brif not (it's optional)
723 jsr GETNCH ; munch the #
724 LA5AB jsr LB141 ; evaluate the expression
725 LA5AE jsr INTCNV ; convert it to an integer in D
726 rolb ; move sign of B into C
727 adca #0 ; add sign of B to A
728 bne LA61F ; brif A doesn't match the sign of B
729 rorb ; restore B (ADCA will have set C if B was negative)
730 stb DEVNUM ; set device number
731 jsr RVEC1 ; do the RAM hook dance
732 beq LA5C4 ; brif device number set to screen/keyboard (valid)
733 bpl LA61F ; brif not negative (not valid)
734 cmpb #-2 ; is it printer or tape?
735 blt LA61F ; brif not (not valid)
736 LA5C4 rts
737 ; Read file name from the line and do an error if anything follows it
738 LA5C5 bsr LA578 ; parse file name
739 jsr GETCCH ; set flags on current character
740 LA5C9 beq LA5C4 ; brif nothing there - it's good
741 jmp LB277 ; raise SN error
742 ; EOF functoin
743 EOF jsr RVEC14 ; do the RAM hook dance
744 lda DEVNUM ; get device number
745 pshs a ; save it (so we can restore it later)
746 bsr LA5AE ; check the device number (which is in FPA0)
747 jsr LA3ED ; check validity for reading
748 LA5DA clrb ; not EOF = 0 (FALSE)
749 lda DEVNUM ; get device number
750 beq LA5E4 ; brif keyboard - never EOF
751 tst CINCTR ; is there anything in the input buffer?
752 bne LA5E4 ; brif so - not EOF
753 comb ; set EOF flag to -1 (true)
754 LA5E4 puls a ; get back original device
755 sta DEVNUM ; restore it
756 LA5E8 sex ; sign extend result to 16 bits
757 jmp GIVABF ; go return the result
758 ; SKIPF command
759 SKIPF bsr LA5C5 ; parse file name
760 bsr LA648 ; look for the file
761 jsr LA6D1 ; read the file
762 bne LA619 ; brif error reading file
763 rts
764 ; OPEN command
765 OPEN jsr RVEC0 ; do the RAM hook dance
766 jsr LB156 ; get file status (input/output)
767 jsr LB6A4 ; get first character of status string
768 pshs b ; save status
769 bsr LA5A2 ; parse a comma then the device number
770 jsr LB26D ; make sure there's a comma
771 bsr LA5C5 ; parse the file name
772 lda DEVNUM ; get device number of the file
773 clr DEVNUM ; reset actual device to the screen
774 puls b ; get back status
775 cmpb #'I ; INPUT?
776 beq LA624 ; brif so - open a file for INPUT
777 cmpb #'O ; OUTPUT?
778 beq LA658 ; brif so - open a file for OUTPUT
779 LA616 ldb #21*2 ; raise FM error
780 skip2
781 LA619 ldb #20*2 ; raise I/O error
782 skip2
783 LA61C ldb #18*2 ; raise AO error
784 skip2
785 LA61F ldb #19*2 ; raise DN error
786 jmp LAC46
787 LA624 inca ; are we opening the tape?
788 bmi LA616 ; brif printer - FM error; printer can't be opened for READ
789 bne LA657 ; brif screen - screen is always open
790 bsr LA648 ; read header block
791 lda CASBUF+9 ; clear A if binary or machine language file
792 anda CASBUF+10
793 beq LA616 ; bad file mode if not data file
794 inc FILSTA ; open file for input
795 LA635 jsr LA701 ; start tape, read block
796 bne LA619 ; brif error during read
797 tst BLKTYP ; check block type
798 beq LA619 ; brif header block - something's wrong
799 bmi LA657 ; brif EOF
800 lda BLKLEN ; get length of block
801 beq LA635 ; brif empty block - read another
802 LA644 sta CINCTR ; set buffer count
803 bra LA652 ; reset buffer pointer
804 LA648 tst FILSTA ; is the file open?
805 bne LA61C ; brif so - AO error
806 bsr LA681 ; search for file
807 bne LA619 ; brif error on read
808 LA650 clr CINCTR ; mark buffer empty
809 LA652 ldx #CASBUF ; set buffer pointer to start of buffer
810 stx CINPTR
811 LA657 rts
812 LA658 inca ; check for tape device
813 bne LA657 ; brif not tape (nothing doing - it's always open)
814 inca ; make file type 1
815 LA65C ldx #0xffff ; ASCII and data mode
816 LA65F tst FILSTA ; is file open?
817 bne LA61C ; brif so - raise error
818 ldu #CASBUF ; point to tape buffer
819 stu CBUFAD ; set address of block to write
820 sta 8,u ; set file type
821 stx 9,u ; set ASCII flag and mode
822 ldx #CFNBUF+1 ; point to file name
823 jsr LA598 ; move file name to the tape buffer
824 clr BLKTYP ; set for header block
825 lda #15 ; 15 bytes in a header block
826 sta BLKLEN ; set block length
827 jsr LA7E5 ; write the block
828 lda #2 ; set file type to output
829 sta FILSTA
830 bra LA650 ; reset file pointers
831 ; Search for correct cassette file name
832 LA681 ldx #CASBUF ; point to cassette buffer
833 stx CBUFAD ; set location to read blocks to
834 LA686 lda CURLIN ; are we in immediate mode?
835 inca
836 bne LA696 ; brif not
837 jsr LA928 ; clear screen
838 ldx CURPOS ; get start of screen (set after clear)
839 ldb #'S ; for "searching"
840 stb ,x++ ; put it on the screen
841 stx CURPOS ; save cursor position to be one past the search indicator
842 LA696 bsr LA701 ; read a block
843 orb BLKTYP ; merge error flag with block type
844 bne LA6D0 ; brif error or not header
845 ldx #CASBUF ; point to block just read
846 ldu #CFNBUF+1 ; point to the desired name
847 ldb #8 ; compare 8 characters
848 clr ,-s ; set flag to "match"
849 LA6A6 lda ,x+ ; get character from just read block
850 ldy CURLIN ; immediate mode?
851 leay 1,y
852 bne LA6B4 ; brif not
853 clr DEVNUM ; set output to screen
854 jsr PUTCHR ; display character
855 LA6B4 suba ,u+ ; subtract from desired file name (nonzero if no match)
856 ora ,s ; merge with match flag
857 sta ,s ; save new match flag (will be nonzero if any character differs)
858 decb ; done all characters?
859 bne LA6A6 ; brif not - do another
860 lda ,s+ ; get match flag (and set flags)
861 beq LA6CB ; brif we have a match
862 tst -9,u ; did we actually have a file name or will any file do?
863 beq LA6CB ; brif any file will do
864 bsr LA6D1 ; go read past the file
865 bne LA6D0 ; return on error
866 bra LA686 ; keep looking
867 LA6CB lda #'F ; for "found"
868 bsr LA6F8 ; put "F" on screen
869 clra ; set Z to indicat eno errors
870 LA6D0 rts
871 LA6D1 tst CASBUF+10 ; check type of file
872 bne LA6DF ; brif "blocked" file
873 jsr CASON ; turn on tape
874 LA6D9 bsr GETBLK ; read a block
875 bsr LA6E5 ; error or EOF?
876 bra LA6D9 ; read another block
877 LA6DF bsr LA701 ; read a single block
878 bsr LA6E5 ; error or EOF?
879 bra LA6DF ; read another block
880 LA6E5 bne LA6ED ; got error reading block
881 lda BLKTYP ; check block type
882 nega ; A is 0 now if EOF
883 bmi LA700 ; brif not end of file
884 deca ; clear error indicator
885 LA6ED sta CSRERR ; set error flag
886 leas 2,s ; don't return to original caller
887 bra LA705 ; turn off motor and return
888 LA6F3 lda VIDRAM ; get first char on screen
889 eora #0x40 ; flip case
890 LA6F8 ldb CURLIN ; immediate mode?
891 incb
892 bne LA700 ; brif not
893 sta VIDRAM ; save flipped case character
894 LA700 rts
895 ; Read a single block from tape (for a "blocked" file)
896 LA701 bsr CASON ; start tape going
897 bsr GETBLK ; read block
898 LA705 jsr LA7E9 ; stop tape
899 ldb CSRERR ; get error status
900 rts
901 ; Read a block from tape - this does the heavy lifting
902 GETBLK orcc #0x50 ; disable interrupts (timing is important)
903 bsr LA6F3 ; reverse video of upper left character in direct mode
904 ldx CBUFAD ; point to destination buffer
905 clra ; reset read byte
906 LA712 bsr LA755 ; read a bit
907 rora ; move bit into accumulator
908 cmpa #0x3c ; have we synched on the start of the block data yet?
909 bne LA712 ; brif not
910 bsr LA749 ; read block type
911 sta BLKTYP
912 bsr LA749 ; get block size
913 sta BLKLEN
914 adda BLKTYP ; accumulate checksum
915 sta CCKSUM ; save current checksum
916 lda BLKLEN ; get back count
917 sta CSRERR ; initialize counter; we use this since it will be ovewritten later anyway
918 beq LA73B ; brif empty block
919 LA72B bsr LA749 ; read a byte
920 sta ,x ; save in buffer
921 cmpa ,x+ ; make sure it wrote
922 bne LA744 ; brif error if it didn't match
923 adda CCKSUM ; accumulate checksum
924 sta CCKSUM
925 dec CSRERR ; read all bytes?
926 bne LA72B ; brif not
927 LA73B bsr LA749 ; read checksum from tape
928 suba CCKSUM ; does it match?
929 beq LA746 ; brif so
930 lda #1 ; checksum error flag
931 skip2
932 LA744 lda #2 ; non-RAM error flag
933 LA746 sta CSRERR ; save error status
934 rts
935 LA749 lda #8 ; read 8 bits
936 sta CPULWD ; initialize counter
937 LA74D bsr LA755 ; read a bit
938 rora ; put it into accumulator
939 dec CPULWD ; got all 8 bits?
940 bne LA74D ; brif not
941 rts
942 LA755 bsr LA75D ; get time between transitions
943 ldb CPERTM ; get timer
944 decb
945 cmpb CMPMID ; set C if timer is below the transition point - high or 1; clear otherwise
946 rts
947 LA75D clr CPERTM ; reset timer
948 tst CBTPHA ; check which phase we synched on
949 bne LA773 ; brif HI-LO synch
950 LA763 bsr LA76C ; read input
951 bcs LA763 ; brif still high
952 LA767 bsr LA76C ; read input
953 bcc LA767 ; brif still low
954 rts
955 LA76C inc CPERTM ; bump timer
956 ldb PIA1 ; get input bit to C
957 rorb
958 rts
959 LA773 bsr LA76C ; read input
960 bcc LA773 ; brif still low
961 LA777 bsr LA76C ; read output
962 bcs LA777 ; brif still high
963 rts
964 ; Start tape and look for sync bytes
965 CASON orcc #0x50 ; disable interrupts
966 bsr LA7CA ; turn on tape
967 clr CPULWD ; reset timer
968 LA782 bsr LA763 ; wait for low-high transition
969 LA784 bsr LA7AD ; wait for it to go low again
970 bhi LA797 ; brif in range for 1200 Hz
971 LA788 bsr LA7A7 ; wait for it to go high again
972 blo LA79B ; brif in range for 2400 Hz
973 dec CPULWD ; decrement counter (synched on low-high)
974 lda CPULWD ; get counter
975 cmpa #-96 ; have we seen 96 1-0-1-0 patterns (48 0x55s)?
976 LA792 bne LA782 ; brif not - wait some more
977 sta CBTPHA ; save phase we synched on
978 rts
979 LA797 bsr LA7A7 ; wait for it to go high again
980 bhi LA784 ; brif another 1200 Hz, 2 in a row, try again
981 LA79B bsr LA7AD ; wait for it to go low again
982 blo LA788 ; brif another 2400 Hz; go try again for high
983 inc CPULWD ; bump counter
984 lda CPULWD ; get counter
985 suba #96 ; set 0 if we've seen enought 0-1-0-1 patterns (0xaa)
986 bra LA792 ; set phase and return or keep waiting
987 LA7A7 clr CPERTM ; reset period timer
988 bsr LA767 ; wait for high
989 bra LA7B1 ; set flags on result
990 LA7AD clr CPERTM ; reset period timer
991 bsr LA777 ; wait for low
992 LA7B1 ldb CPERTM ; get period count
993 cmpb CMP0 ; is it too long for 1200Hz?
994 bhi LA7BA ; brif so - reset counts
995 cmpb CMP1 ; set C if 2400Hz, clear C if 1200 Hz
996 rts
997 LA7BA clr CPULWD ; reset sync counter (too slow or drop out)
998 rts
999 ; MOTOR command
1000 MOTOR tfr a,b ; save ON/OFF
1001 jsr GETNCH ; eat the ON/OFF token
1002 cmpb #0xaa ; OFF?
1003 beq LA7E9 ; brif so - turn off tape
1004 cmpb #0x88 ; ON?
1005 jsr LA5C9 ; SN error if no match
1006 ; Turn on tape
1007 LA7CA lda PIA1+1 ; get motor control value
1008 ora #8 ; turn on bit 3 (starts motor)
1009 bsr LA7F0 ; put it back (dumb but it saves a byte)
1010 LA7D1 ldx ZERO ; maximum delay timer
1011 LA7D3 leax -1,x ; count down
1012 bne LA7D3 ; brif not at 0 yet
1013 rts
1014 ; Write a synch leader to tape
1015 WRLDR orcc #0x50 ; disable interrupts
1016 bsr LA7CA ; turn on tape
1017 ldx SYNCLN ; get count of 0x55s to write
1018 LA7DE bsr LA828 ; write a 0x55
1019 leax -1,x ; done?
1020 bne LA7DE ; brif not
1021 rts
1022 ; Write sync bytes and a block, then stop tape
1023 LA7E5 bsr WRLDR ; write sync
1024 LA7E7 bsr SNDBLK ; write block
1025 ; Turn off tape
1026 LA7E9 andcc #0xaf ; enable interrupts
1027 lda PIA1+1 ; get control register
1028 anda #0xf7 ; disable motor bit
1029 LA7F0 sta PIA1+1 ; set motor enable bit
1030 rts
1031 ; Write a block to tape.
1032 SNDBLK orcc #0x50 ; disable interrupts
1033 ldb BLKLEN ; get block size
1034 stb CSRERR ; initialize character counter
1035 lda BLKLEN ; initialize checksum
1036 beq LA805 ; brif empty block
1037 ldx CBUFAD ; point to tape buffer
1038 LA800 adda ,x+ ; accumulate checksum
1039 decb ; end of block data?
1040 bne LA800 ; brif not
1041 LA805 adda BLKTYP ; accumulate block type into checksum
1042 sta CCKSUM ; save calculated checksum
1043 ldx CBUFAD ; point to buffer
1044 bsr LA828 ; send a 0x55
1045 lda #0x3c ; and then a 0x3c
1046 bsr LA82A
1047 lda BLKTYP ; send block type
1048 bsr LA82A
1049 lda BLKLEN ; send block size
1050 bsr LA82A
1051 tsta ; empty block?
1052 beq LA824 ; brif so
1053 LA81C lda ,x+ ; send character from block data
1054 bsr LA82A
1055 dec CSRERR ; are we done yet?
1056 bne LA81C ; brif not
1057 LA824 lda CCKSUM ; send checksum
1058 bsr LA82A
1059 LA828 lda #0x55 ; send a 0x55
1060 LA82A pshs a ; save output byte
1061 ldb #1 ; initialize bit probe
1062 LA82E lda CLSTSN ; get ending value of last cycle
1063 sta PIA1 ; set DA
1064 ldy #LA85C ; point to sine wave table
1065 bitb ,s ; is bit set?
1066 bne LA848 ; brif so - do high frequency
1067 LA83B lda ,y+ ; get next sample (use all for low frequency)
1068 cmpy #LA85C+36 ; end of table?
1069 beq LA855 ; brif so
1070 sta PIA1 ; set output sample
1071 bra LA83B ; do another sample
1072 LA848 lda ,y++ ; get next sample (use every other for high frequency)
1073 cmpy #LA85C+36 ; end of table?
1074 beq LA855 ; brif so
1075 sta PIA1 ; send output sample
1076 bra LA848 ; do another sample
1077 LA855 sta CLSTSN ; save last sample that *would* have been sent
1078 lslb ; shift mask to next bit
1079 bcc LA82E ; brif not done all 8 bits
1080 puls a,pc ; get back original character and return
1081 ; This is the sample table for the tape sine wave
1082 LA85C fcb 0x82,0x92,0xaa,0xba,0xca,0xda
1083 fcb 0xea,0xf2,0xfa,0xfa,0xfa,0xf2
1084 fcb 0xea,0xda,0xca,0xba,0xaa,0x92
1085 fcb 0x7a,0x6a,0x52,0x42,0x32,0x22
1086 fcb 0x12,0x0a,0x02,0x02,0x02,0x0a
1087 fcb 0x12,0x22,0x32,0x42,0x52,0x6a
1088 ; SET command
1089 SET bsr LA8C1 ; get absolute screen position of graphics block
1090 pshs x ; save character location
1091 jsr LB738 ; evaluate comma then expression in B
1092 puls x ; get back character pointer
1093 cmpb #8 ; valid colour?
1094 bhi LA8D5 ; brif not
1095 decb ; normalize colours
1096 bmi LA895 ; brif colour 0 (use current colour)
1097 lda #0x10 ; 16 patterns per colour
1098 mul
1099 bra LA89D ; go save the colour
1100 LA895 ldb ,x ; get current value
1101 bpl LA89C ; brif not grahpic
1102 andb #0x70 ; keep only the colour
1103 skip1
1104 LA89C clrb ; reset block to all black
1105 LA89D pshs b ; save colour
1106 bsr LA90D ; force a )
1107 lda ,x ; get current screen value
1108 bmi LA8A6 ; brif graphic block already
1109 clra ; force all pixels off
1110 LA8A6 anda #0x0f ; keep only pixel data
1111 ora GRBLOK ; set the desired pixel
1112 ora ,s+ ; merge with desired colour
1113 LA8AC ora #0x80 ; force it to be a graphic block
1114 sta ,x ; put new block on screen
1115 rts
1116 ; RESET command
1117 RESET bsr LA8C1 ; get address of desired block
1118 bsr LA90D ; force a )
1119 clra ; zero block (no pixels)
1120 ldb ,x ; is it graphics?
1121 bpl LA8AC ; brif not - just blank the block
1122 com GRBLOK ; invert pixel data
1123 andb GRBLOK ; turn off the desired pixel
1124 stb ,x ; put new pixel data on screen
1125 rts
1126 ; Parse SET/RESET/POINT coordinates except for closing )
1127 LA8C1 jsr LB26A ; make sure it starts with (
1128 LA8C4 jsr RVEC21 ; do the RAM hook dance
1129 jsr LB70B ; get first coordinate
1130 cmpb #63 ; valid horizontal coordinate
1131 bhi LA8D5 ; brif out of range
1132 pshs b ; save horizontal coordinate
1133 jsr LB738 ; look for , followed by vertical coordinate
1134 cmpb #31 ; in range for vertical?
1135 LA8D5 bhi LA948 ; brif not
1136 pshs b ; save vertical coordinate
1137 lsrb ; divide by two (two blocks per row)
1138 lda #32 ; 32 bytes per row
1139 mul ; now we have the offset into video RAM
1140 ldx #VIDRAM ; point to start of screen
1141 leax d,x ; now X points to the correct character row
1142 ldb 1,s ; get horizontal coordinate
1143 lsrb ; divide by two (two per character cell)
1144 abx ; now we're pointing to the correct character cell
1145 puls a,b ; get back coordinates (vertical in A)
1146 anda #1 ; keep only row offset of vertical
1147 rorb ; get column offset of horizontal to C
1148 rola ; now we have "row * 2 + col" in A
1149 ldb #0x10 ; make a bit mask (one bit left of first pixel)
1150 LA8EE lsrb ; move mask right
1151 deca ; at the right pixel?
1152 bpl LA8EE ; brif not
1153 stb GRBLOK ; save graphics block mask
1154 rts
1155 ; POINT function
1156 POINT bsr LA8C4 ; evaluate coordinates
1157 ldb #0xff ; default colour value is -1 (not graphics)
1158 lda ,x ; get character
1159 bpl LA90A ; brif not graphics
1160 anda GRBLOK ; is desired pixel set?
1161 beq LA909 ; brif not - return 0 for "black"
1162 ldb ,x ; get graphics data
1163 lsrb ; shift right 4 to get colour in low bits
1164 lsrb
1165 lsrb
1166 lsrb
1167 andb #7 ; lose the graphics block bias
1168 LA909 incb ; shift colours into 1 to 8 range
1169 LA90A jsr LA5E8 ; convert B to floating point
1170 LA90D jmp LB267 ; make sure we have a ) and return
1171 ; CLS command
1172 CLS jsr RVEC22 ; do the RAM hook dance
1173 LA913 beq LA928 ; brif no colour - just do a basic screen clear
1174 jsr LB70B ; evaluate colour number
1175 cmpb #8 ; valid colour?
1176 bhi LA937 ; brif not - do the easter egg
1177 tstb ; color 0?
1178 beq LA925 ; brif so
1179 decb ; normalize to 0 based colour numbers
1180 lda #0x10 ; 16 blocks per colour
1181 mul ; now we have the base code for that colour
1182 orb #0x0f ; set all pixels
1183 LA925 orb #0x80 ; make it a graphics block
1184 skip2
1185 LA928 ldb #0x60 ; VDG screen space character
1186 ldx #VIDRAM ; point to start of screen
1187 LA92D stx CURPOS ; set cursor position
1188 LA92F stb ,x+ ; blank a character
1189 cmpx #VIDRAM+511 ; end of screen?
1190 bls LA92F ; brif not
1191 rts
1192 LA937 bsr LA928 ; clear te screen
1193 ldx #LA166-1 ; point to the easter egg
1194 jmp LB99C ; go display it
1195 ; Evaluate an expression to B, prefixed by a comma, and do FC error if 0
1196 LA93F jsr LB26D ; force a comma
1197 LA942 jsr LB70B ; evaluate expression to B
1198 tstb ; is it 0?
1199 bne LA984 ; brif not - return
1200 LA948 jmp LB44A ; raise FC error
1201 ; SOUND command
1202 SOUND bsr LA942 ; evaluate frequency
1203 stb SNDTON ; save it
1204 bsr LA93F ; evaluate duration (after a comma)
1205 LA951 lda #4 ; constant factor for duration (each increment is 1/15 of a second)
1206 mul
1207 std SNDDUR ; save length of sound (IRQ will count it down)
1208 lda PIA0+3 ; enable 60 Hz interrupt
1209 ora #1
1210 sta PIA0+3
1211 clr ARYDIS ; clear array disable flag for some reason
1212 bsr LA9A2 ; connect DAC to MUX output
1213 bsr LA976 ; turn on sound
1214 LA964 bsr LA985 ; store mid range output value and delay
1215 lda #0xfe ; store high value and delay
1216 bsr LA987
1217 bsr LA985 ; store mid range value and delay
1218 lda #2 ; store low value and delay
1219 bsr LA987
1220 ldx SNDDUR ; has timer expired?
1221 bne LA964 ; brif not, do another wave
1222 ; Disable sound output
1223 LA974 clra ; bit 3 to 0 will disable output
1224 skip2
1225 ; Enable sound output
1226 LA976 lda #8 ; bit 3 set to enable output
1227 sta ,-s ; save desired value
1228 lda PIA1+3 ; get control register value
1229 anda #0xf7 ; reset value
1230 ora ,s+ ; set to desired value
1231 sta PIA1+3 ; set new sound output status
1232 LA984 rts
1233 LA985 lda #0x7e ; mid range value for DAC
1234 LA987 sta PIA1 ; set DAC output value
1235 lda SNDTON ; get frequency
1236 LA98C inca ; increment it (gives shorter count with higher values, so higher frequencies work)
1237 bne LA98C ; brif not done yet
1238 rts
1239 ; AUDIO command
1240 AUDIO tfr a,b ; save ON/OFF token
1241 jsr GETNCH ; munch the ON/OFF token
1242 cmpb #0xaa ; OFF?
1243 beq LA974 ; brif so
1244 subb #0x88 ; ON?
1245 jsr LA5C9 ; do SN error if not
1246 incb ; now B is 1 - cassette sound source
1247 bsr LA9A2 ; set MUX input to tape
1248 bra LA976 ; enable sound
1249 ; Set MUX source to value in B
1250 LA9A2 ldu #PIA0+1 ; point to PIA0 control register A
1251 bsr LA9A7 ; program bit 0 then fall through for bit 1
1252 LA9A7 lda ,u ; get control register value
1253 anda #0xf7 ; reset mux control bit
1254 asrb ; shift desired value to C
1255 bcc LA9B0 ; brif this bit is clear
1256 ora #8 ; set the bit
1257 LA9B0 sta ,u++ ; set register value and move to next register
1258 rts
1259 ; IRQ service routine
1260 BIRQSV lda PIA0+3 ; check for VSYNC interrupt
1261 bpl LA9C5 ; brif not - return. BUG: should clear HSYNC interrupt status first
1262 lda PIA0+2 ; clear VSYNC interrupt status
1263 ldx >SNDDUR ; are we counting down for SOUND? (force extended in case DP is modified)
1264 beq LA9C5 ; brif not
1265 leax -1,x ; count down one tick
1266 stx >SNDDUR ; save new count (forced extended in case DP is modified)
1267 LA9C5 rti
1268 ; JOYSTK function
1269 JOYSTK jsr LB70E ; evaluate which joystick axis is desired
1270 cmpb #3 ; valid axis?
1271 lbhi LB44A ; brif not
1272 tstb ; want axis 0?
1273 bne LA9D4 ; brif not
1274 bsr GETJOY ; read axis data if axis 0
1275 LA9D4 ldx #POTVAL ; point to axis values
1276 ldb FPA0+3 ; get desired axis
1277 ldb b,x ; get axis value
1278 jmp LB4F3 ; return value
1279 ; Read all four joystick axes. Note that this routine will try 10 times to get a value that matches
1280 ; the value obtained during the *previous call to this routine*. Thus, if the axis value has changed,
1281 ; this routine will do the read *ten times* before just returning the last value. This is assininely
1282 ; slow and probably a bug since it seems more logical to look for two matching reads in a row. Note
1283 ; also that this routine should be using PSHS and PULS but it doesn't.
1284 GETJOY bsr LA974 ; turn off sound
1285 ldx #POTVAL+4 ; point to the end of the axis data (we'll work backwards)
1286 ldb #3 ; start with axis 3
1287 LA9E5 lda #10 ; 10 tries to see if we match *the last call* to this routine
1288 std ,--s ; save retry counter and axis number
1289 bsr LA9A2 ; set MUX for the correct axis
1290 LA9EB ldd #0x4080 ; set initial trial value to mid range and the next difference to add/subtract to half
1291 LA9EE sta ,-s ; store the add/subtract value
1292 orb #2 ; keep rs232 output marking
1293 stb PIA1 ; set DAC output to the trial value
1294 eorb #2 ; remove RS232 output value
1295 lda PIA0 ; read the comparator
1296 bmi LA9FF ; brif comparator output is high (DAC is lower than the axis value)
1297 subb ,s ; subtract next bit value (split the difference toward 0)
1298 skip2
1299 LA9FF addb ,s ; add next bit value (split the different toward infinity)
1300 lda ,s+ ; get bit value back
1301 lsra ; cut in half
1302 cmpa #1 ; have we done that last value for the DAC?
1303 bne LA9EE ; brif not
1304 lsrb ; normalize the axis value
1305 lsrb
1306 cmpb -1,x ; does it match the read from the last call to this routine?
1307 beq LAA12 ; brif so
1308 dec ,s ; are we out of retries?
1309 bne LA9EB ; brif not - try again
1310 LAA12 stb ,-x ; save new value and move pointer back
1311 ldd ,s++ ; get axis counter and clean up retry counter
1312 decb ; move to next axis
1313 bpl LA9E5 ; brif still more axes to do
1314 rts
1315 ; This is the "bottom half" of the character fetching routines.
1316 BROMHK cmpa #'9+1 ; is it >= colon?
1317 bhs LAA28 ; brif so Z set if colon, C clear.
1318 cmpa #0x20 ; space?
1319 bne LAA24 ; brif not
1320 jmp GETNCH ; move on to another character if space
1321 LAA24 suba #'0 ; normalize ascii digit to 0-9; we already handled above digit 9
1322 suba #-'0 ; this will cause a carry for any value that was already positive
1323 LAA28 rts
1324 ; Jump table for functions
1325 LAA29 fdb SGN ; SGN 0x80
1326 fdb INT ; INT 0x81
1327 fdb ABS ; ABS 0x82
1328 fdb USRJMP ; USR 0x83
1329 fdb RND ; RND 0x84
1330 fdb SIN ; SIN 0x85
1331 fdb PEEK ; PEEK 0x86
1332 fdb LEN ; LEN 0x87
1333 fdb STR ; STR$ 0x88
1334 fdb VAL ; VAL 0x89
1335 fdb ASC ; ASC 0x8a
1336 fdb CHR ; CHR$ 0x8b
1337 fdb EOF ; EOF 0x8c
1338 fdb JOYSTK ; JOYSTK 0x8d
1339 fdb LEFT ; LEFT$ 0x8e
1340 fdb RIGHT ; RIGHT$ 0x8f
1341 fdb MID ; MID$ 0x90
1342 fdb POINT ; POINT 0x91
1343 fdb INKEY ; INKEY$ 0x92
1344 fdb MEM ; MEM 0x93
1345 ; Operator precedence and jump table (binary ops except relational)
1346 LAA51 fcb 0x79 ; +
1347 fdb LB9C5
1348 fcb 0x79 ; -
1349 fdb LB9BC
1350 fcb 0x7b ; *
1351 fdb LBACC
1352 fcb 0x7b ; /
1353 fdb LBB91
1354 fcb 0x7f ; ^ (exponentiation)
1355 fdb EXPJMP
1356 fcb 0x50 ; AND
1357 fdb LB2D5
1358 fcb 0x46 ; OR
1359 fdb LB2D4
1360 ; Reserved words table for commands
1361 LAA66 fcs 'FOR' ; 0x80
1362 fcs 'GO' ; 0x81
1363 fcs 'REM' ; 0x82
1364 fcs "'" ; 0x83
1365 fcs 'ELSE' ; 0x84
1366 fcs 'IF' ; 0x85
1367 fcs 'DATA' ; 0x86
1368 fcs 'PRINT' ; 0x87
1369 fcs 'ON' ; 0x88
1370 fcs 'INPUT' ; 0x89
1371 fcs 'END' ; 0x8a
1372 fcs 'NEXT' ; 0x8b
1373 fcs 'DIM' ; 0x8c
1374 fcs 'READ' ; 0x8d
1375 fcs 'RUN' ; 0x8e
1376 fcs 'RESTORE' ; 0x8f
1377 fcs 'RETURN' ; 0x90
1378 fcs 'STOP' ; 0x91
1379 fcs 'POKE' ; 0x92
1380 fcs 'CONT' ; 0x93
1381 fcs 'LIST' ; 0x94
1382 fcs 'CLEAR' ; 0x95
1383 fcs 'NEW' ; 0x96
1384 fcs 'CLOAD' ; 0x97
1385 fcs 'CSAVE' ; 0x98
1386 fcs 'OPEN' ; 0x99
1387 fcs 'CLOSE' ; 0x9a
1388 fcs 'LLIST' ; 0x9b
1389 fcs 'SET' ; 0x9c
1390 fcs 'RESET' ; 0x9d
1391 fcs 'CLS' ; 0x9e
1392 fcs 'MOTOR' ; 0x9f
1393 fcs 'SOUND' ; 0xa0
1394 fcs 'AUDIO' ; 0xa1
1395 fcs 'EXEC' ; 0xa2
1396 fcs 'SKIPF' ; 0xa3
1397 fcs 'TAB(' ; 0xa4
1398 fcs 'TO' ; 0xa5
1399 fcs 'SUB' ; 0xa6
1400 fcs 'THEN' ; 0xa7
1401 fcs 'NOT' ; 0xa8
1402 fcs 'STEP' ; 0xa9
1403 fcs 'OFF' ; 0xaa
1404 fcs '+' ; 0xab
1405 fcs '-' ; 0xac
1406 fcs '*' ; 0xad
1407 fcs '/' ; 0xae
1408 fcs '^' ; 0xaf
1409 fcs 'AND' ; 0xb0
1410 fcs 'OR' ; 0xb1
1411 fcs '>' ; 0xb2
1412 fcs '=' ; 0xb3
1413 fcs '<' ; 0xb4
1414 ; Reserved word list for functions
1415 LAB1A fcs 'SGN' ; 0x80
1416 fcs 'INT' ; 0x81
1417 fcs 'ABS' ; 0x82
1418 fcs 'USR' ; 0x83
1419 fcs 'RND' ; 0x84
1420 fcs 'SIN' ; 0x85
1421 fcs 'PEEK' ; 0x86
1422 fcs 'LEN' ; 0x87
1423 fcs 'STR$' ; 0x88
1424 fcs 'VAL' ; 0x89
1425 fcs 'ASC' ; 0x8a
1426 fcs 'CHR$' ; 0x8b
1427 fcs 'EOF' ; 0x8c
1428 fcs 'JOYSTK' ; 0x8d
1429 fcs 'LEFT$' ; 0x8e
1430 fcs 'RIGHT$' ; 0x8f
1431 fcs 'MID$' ; 0x90
1432 fcs 'POINT' ; 0x91
1433 fcs 'INKEY$' ; 0x92
1434 fcs 'MEM' ; 0x93
1435 ; Jump table for commands
1436 LAB67 fdb FOR ; 0x80 FOR
1437 fdb GO ; 0x81 GO
1438 fdb REM ; 0x82 REM
1439 fdb REM ; 0x83 '
1440 fdb REM ; 0x84 ELSE
1441 fdb IFTOK ; 0x85 IF
1442 fdb DATA ; 0x86 DATA
1443 fdb PRINT ; 0x87 PRINT
1444 fdb ON ; 0x88 ON
1445 fdb INPUT ; 0x89 INPUT
1446 fdb ENDTOK ; 0x8a END
1447 fdb NEXT ; 0x8b NEXT
1448 fdb DIM ; 0x8c DIM
1449 fdb READ ; 0x8d READ
1450 fdb RUN ; 0x8e RUN
1451 fdb RESTOR ; 0x8f RESTORE
1452 fdb RETURN ; 0x90 RETURN
1453 fdb STOP ; 0x91 STOP
1454 fdb POKE ; 0x92 POKE
1455 fdb CONT ; 0x93 CONT
1456 fdb LIST ; 0x94 LIST
1457 fdb CLEAR ; 0x95 CLEAR
1458 fdb NEW ; 0x96 NEW
1459 fdb CLOAD ; 0x97 CLOAD
1460 fdb CSAVE ; 0x98 CSAVE
1461 fdb OPEN ; 0x99 OPEN
1462 fdb CLOSE ; 0x9a CLOSE
1463 fdb LLIST ; 0x9b LLIST
1464 fdb SET ; 0x9c SET
1465 fdb RESET ; 0x9d RESET
1466 fdb CLS ; 0x9e CLS
1467 fdb MOTOR ; 0x9f MOTOR
1468 fdb SOUND ; 0xa0 SOUND
1469 fdb AUDIO ; 0xa1 AUDIO
1470 fdb EXEC ; 0xa2 EXEC
1471 fdb SKIPF ; 0xa3 SKIPF
1472 ; Error message table
1473 LABAF fcc 'NF' ; 0 NEXT without FOR
1474 fcc 'SN' ; 1 Syntax error
1475 fcc 'RG' ; 2 RETURN without GOSUB
1476 fcc 'OD' ; 3 Out of data
1477 fcc 'FC' ; 4 Illegal function call
1478 fcc 'OV' ; 5 Overflow
1479 fcc 'OM' ; 6 Out of memory
1480 fcc 'UL' ; 7 Undefined line number
1481 fcc 'BS' ; 8 Bad subscript
1482 fcc 'DD' ; 9 Redimensioned array
1483 fcc '/0' ; 10 Division by 0
1484 fcc 'ID' ; 11 Illegal direct statement
1485 fcc 'TM' ; 12 Type mismatch
1486 fcc 'OS' ; 13 Out of string space
1487 fcc 'LS' ; 14 String too long
1488 fcc 'ST' ; 15 String formula too complex
1489 fcc 'CN' ; 16 Can't continue
1490 fcc 'FD' ; 17 Bad file data
1491 fcc 'AO' ; 18 File already open
1492 fcc 'DN' ; 19 Device number error
1493 fcc 'IO' ; 20 Input/output error
1494 fcc 'FM' ; 21 Bad file mode
1495 fcc 'NO' ; 22 File not open
1496 fcc 'IE' ; 23 Input past end of file
1497 fcc 'DS' ; 24 Direct statement in file
1498 LABE1 fcn ' ERROR'
1499 LABE8 fcn ' IN '
1500 LABED fcb 0x0d
1501 LABEE fcc 'OK'
1502 fcb 0x0d,0x00
1503 LABF2 fcb 0x0d
1504 fcn 'BREAK'
1505 ; Search stack for a FOR/NEXT stack frame. Stop search when something that isn't a FOR/NEXT
1506 ; stack frame is found. Enter with the index variable descriptor pointer in VARDES, or NULL
1507 ; for the first match.
1508 ;
1509 ; NOTE: this routine can be reworked to avoid needed two temporaries by taking advantage of the
1510 ; 6809's registers. This requires some minor tweaks where the routine is called. Further, the
1511 ; use of B is completely pointless and, even if B is going to be used, why is it reloaded on
1512 ; every loop?
1513 LABF9 leax 4,s ; skip past our caller and the main command loop return address
1514 LABFB ldb #18 ; each FOR/NEXT frame is 18 bytes
1515 stx TEMPTR ; save current search pointer
1516 lda ,x ; get first byte of this frame
1517 suba #0x80 ; set to 0 if FOR/NEXT
1518 bne LAC1A ; brif not FOR/NEXT (we hit the end of the stack for a GOSUB frame)
1519 ldx 1,x ; get index variable descriptor
1520 stx TMPTR1 ; save it
1521 ldx VARDES ; get desired index descriptor
1522 beq LAC16 ; brif NULL - we found something
1523 cmpx TMPTR1 ; does this one match?
1524 beq LAC1A ; brif so
1525 ldx TEMPTR ; get back frame pointer
1526 abx ; move to next entry
1527 bra LABFB ; check next block of data
1528 LAC16 ldx TMPTR1 ; get index variable of this frame
1529 stx VARDES ; set it as the one found
1530 LAC1A ldx TEMPTR ; get matching frame pointer
1531 tsta ; set Z if FOR/NEXT
1532 rts
1533 ; This is a block copy routine which copies from top to bottom. It's not clear that the use of
1534 ; this routine actually saves any ROM space compared to just implementing the copies directly
1535 ; once all the marshalling to set up the parameter variables is taken into account.
1536 LAC1E bsr LAC37 ; check to see if stack collides with D
1537 LAC20 ldu V41 ; point to destination
1538 leau 1,u ; offset for pre-dec
1539 ldx V43 ; point to source
1540 leax 1,x ; offset for pre-dec
1541 LAC28 lda ,-x ; get source byte
1542 pshu a ; store at destination (sta ,-u would be less weird)
1543 cmpx V47 ; at the bottom of the copy?
1544 bne LAC28 ; brif not
1545 stu V45 ; save final destination address
1546 LAC32 rts
1547 ; Check for 2*B (0 <= B <= 127) bytes for free memory
1548 LAC33 clra ; zero extend
1549 aslb ; times 2 (loses bit 7 of B)
1550 addd ARYEND ; add to top of used memory
1551 LAC37 addd #STKBUF ; add a fudge factor for interpreter operation
1552 bcs LAC44 ; brif >65535!
1553 sts BOTSTK ; get current stack pointer
1554 cmpd BOTSTK ; is our new address above that?
1555 blo LAC32 ; brif not - no error
1556 LAC44 ldb #6*2 ; raise OM error
1557 ; The error servicing routine
1558 LAC46 jsr RVEC16 ; do the RAM hook dance (ON ERROR reserved hook)
1559 LAC49 jsr RVEC17 ; do the RAM hook dance again
1560 jsr LA7E9 ; turn off tape
1561 jsr LA974 ; disable sound
1562 jsr LAD33 ; reset stack, etc.
1563 clr DEVNUM ; reset output to screen
1564 jsr LB95C ; do a newline
1565 jsr LB9AF ; send a ?
1566 ldx #LABAF ; point to error table
1567 abx ; offset to correct message
1568 bsr LACA0 ; send a char from X
1569 bsr LACA0 ; send another char from X
1570 ldx #LABE1-1 ; point to "ERROR" message
1571 LAC68 jsr LB99C ; print ERROR message (or BREAK)
1572 lda CURLIN ; are we in immediate mode?
1573 inca
1574 beq LAC73 ; brif not - go to immediate mode
1575 jsr LBDC5 ; print "IN ****"
1576 ; This is the immediate mode loop
1577 LAC73 jsr LB95C ; do a newline if needed
1578 LAC76 ldx #LABEE-1 ; point to prompt (without leading CR)
1579 jsr LB99C ; show prompt
1580 LAC7C jsr LA390 ; read an input line
1581 ldu #0xffff ; flag immediate mode
1582 stu CURLIN
1583 bcs LAC7C ; brif we ended on BREAK - just go for another line
1584 tst CINBFL ; EOF?
1585 lbne LA4BF ; brif so
1586 stx CHARAD ; save start of input line as input pointer
1587 jsr GETNCH ; get character from input line
1588 beq LAC7C ; brif no input
1589 bcs LACA5 ; brif numeric - adding or removing a line number
1590 ldb #2*24 ; code for "direct statement in file"
1591 tst DEVNUM ; keyboard input?
1592 bne LAC46 ; brif not - complain about direct statement
1593 jsr LB821 ; go tokenize the input line
1594 jmp LADC0 ; go execute the newly tokenized line
1595 LACA0 lda ,x+ ; get character and advance pointer
1596 jmp LB9B1 ; output it
1597 LACA5 jsr LAF67 ; convert line number to binary
1598 ldx BINVAL ; get converted number
1599 stx LINHDR ; put it before the line we just read
1600 jsr LB821 ; tokenize the input line
1601 stb TMPLOC ; save line length
1602 bsr LAD01 ; find where the line should be in the program
1603 bcs LACC8 ; brif the line number isn't already present
1604 ldd V47 ; get address where the line is in the program
1605 subd ,x ; get the difference between here and the end of the line (negative)
1606 addd VARTAB ; subtract line length from the end of the program
1607 std VARTAB ; save new end of program address
1608 ldu ,x ; get start of next line
1609 LACC0 pulu a ; get source byte (lda ,u+ would be less weird)
1610 sta ,x+ ; move it down
1611 cmpx VARTAB ; have we moved everything yet?
1612 bne LACC0 ; brif not
1613 LACC8 lda LINBUF ; see if there is actually a line to input
1614 beq LACE9 ; brif not - we just needed to remove the line
1615 ldd VARTAB ; get current end of program
1616 std V43 ; set as source pointer
1617 addb TMPLOC ; add in the length of the new line
1618 adca #0
1619 std V41 ; save destination pointer
1620 jsr LAC1E ; make sure there's enough room and then make a hole for the new line
1621 ldu #LINHDR-2 ; point to the line (well, 4 bytes before it, incl line number and fake next line pointer)
1622 LACDD pulu a ; get byte from new line (lda ,u+ would be less weird)
1623 sta ,x+ ; stow it
1624 cmpx V45 ; at the end of the hole we just made?
1625 bne LACDD ; brif not
1626 ldx V41 ; get save new top of program address
1627 stx VARTAB
1628 LACE9 bsr LAD21 ; reset variables, etc.
1629 bsr LACEF ; adjust next line pointers
1630 bra LAC7C ; go read another input line
1631 ; Recompute next line pointers
1632 LACEF ldx TXTTAB ; point to start of program
1633 LACF1 ldd ,x ; get address of next line
1634 beq LAD16 ; brif end of program
1635 leau 4,x ; move past pointer and line number
1636 LACF7 lda ,u+ ; are we at the end of the line?
1637 bne LACF7 ; brif not
1638 stu ,x ; save new next line pointer
1639 ldx ,x ; point to next line
1640 bra LACF1 ; process the next line
1641 ; Find a line in the program
1642 LAD01 ldd BINVAL ; get desired line number
1643 ldx TXTTAB ; point to start of program
1644 LAD05 ldu ,x ; get address of next line
1645 beq LAD12 ; brif end of program
1646 cmpd 2,x ; do we have a match?
1647 bls LAD14 ; brif our search number is <= the number here
1648 ldx ,x ; move to next line
1649 bra LAD05 ; check another line
1650 LAD12 orcc #1 ; set C for not found
1651 LAD14 stx V47 ; save address of matching line *or* line just after where it would have been
1652 LAD16 rts
1653 ; NEW command
1654 ; This routine has multiple entry points used for various "levels" of NEW
1655 NEW bne LAD14 ; brif there was input given; should be LAD16!
1656 LAD19 ldx TXTTAB ; point to start of program
1657 clr ,x+ ; blank out program (with NULL next line pointer)
1658 clr ,x+
1659 stx VARTAB ; save end of program
1660 LAD21 ldx TXTTAB ; get start of program
1661 jsr LAEBB ; put input pointer there
1662 LAD26 ldx MEMSIZ ; reset string space
1663 stx STRTAB
1664 jsr RESTOR ; reset DATA pointer
1665 ldx VARTAB ; clear out scalars and arrays
1666 stx ARYTAB
1667 stx ARYEND
1668 LAD33 ldx #STRSTK ; reset the string stack
1669 stx TEMPPT
1670 ldx ,s ; get return address (we're going to reset the stack)
1671 lds FRETOP ; reset the stack to top of memory
1672 clr ,-s ; put stopper so FOR/NEXT search will actually stop here
1673 clr OLDPTR ; reset "CONT" state
1674 clr OLDPTR+1
1675 clr ARYDIS ; un-disable arrays
1676 jmp ,x ; return to original caller
1677 ; FOR command
1678 FOR lda #0x80 ; disable array parsing
1679 sta ARYDIS
1680 jsr LET ; assign start value to index
1681 jsr LABF9 ; search stack for matching FOR/NEXT frame
1682 leas 2,s ; lose return address
1683 bne LAD59 ; brif variable not already being used
1684 ldx TEMPTR ; get address of matched data
1685 leas b,x ; move stack pointer to the end of it (B is set to 18 in the stack search)
1686 LAD59 ldb #9 ; is there room for 18 bytes in memory?
1687 jsr LAC33
1688 jsr LAEE8 ; get address of the end of this statement in X
1689 ldd CURLIN ; get line number
1690 pshs x,b,a ; save next line address and current line number
1691 ldb #0xa5 ; make sure we have TO
1692 jsr LB26F
1693 jsr LB143 ; make sure we have a numeric index
1694 jsr LB141 ; evaluate terminal condition value
1695 ldb FP0SGN ; pack FPA0 in place
1696 orb #0x7f
1697 andb FPA0
1698 stb FPA0
1699 ldy #LAD7F ; where to come back to
1700 jmp LB1EA ; stash terminal condition on the stack
1701 LAD7F ldx #LBAC5 ; point to FP 1.0 (default step)
1702 jsr LBC14 ; unpack it to FPA0
1703 jsr GETCCH ; get character after the terminal
1704 cmpa #0xa9 ; is it STEP?
1705 bne LAD90 ; brif not
1706 jsr GETNCH ; eat STEP
1707 jsr LB141 ; evaluate step condition
1708 LAD90 jsr LBC6D ; get "status" of FPA0
1709 jsr LB1E6 ; stash FPA0 on the stack (for step value)
1710 ldd VARDES ; get variable descriptor pointer
1711 pshs d ; put that on the stack too
1712 lda #0x80 ; flag the frame as a FOR/NEXT frame
1713 pshs a
1714 ; Main command interpretation loop
1715 LAD9E jsr RVEC20 ; do the RAM hook dance
1716 andcc #0xaf ; make sure interrupts are running
1717 bsr LADEB ; check for BREAK/pause
1718 ldx CHARAD ; get input pointer
1719 stx TINPTR ; save input pointer for start of line
1720 lda ,x+ ; get current input character
1721 beq LADB4 ; brif end of line - move to another line
1722 cmpa #': ; end of statement?
1723 beq LADC0 ; brif so - keep processing
1724 LADB1 jmp LB277 ; raise a syntax error
1725 LADB4 lda ,x++ ; get MSB of next line pointer and skip past pointer
1726 sta ENDFLG
1727 beq LAE15 ; brif MSB of next line address is 0 (do END)
1728 ldd ,x+ ; get line number but only advance one
1729 std CURLIN ; set current line number
1730 stx CHARAD ; set input pointer to one before line text
1731 LADC0 jsr GETNCH ; move past statement separator or to first character in line
1732 bsr LADC6 ; process a command
1733 bra LAD9E ; handle next statement or line
1734 LADC6 beq LAE40 ; return if end of statement
1735 tsta ; is it a token?
1736 lbpl LET ; brif not - do a LET
1737 cmpa #0xa3 ; above SKIPF?
1738 bhi LADDC ; brif so
1739 ldx COMVEC+3 ; point to jump table
1740 lsla ; two bytes per entry (loses the token bias)
1741 tfr a,b ; put it in B for unsigned ABX
1742 abx
1743 jsr GETNCH ; move past token
1744 jmp [,x] ; transfer control to the handler (which will return to the main loop)
1745 LADDC cmpa #0xb4 ; is it a non-executable token?
1746 bls LADB1 ; brif so
1747 jmp [COMVEC+13] ; transfer control to ECB command handler
1748 ; RESTORE command
1749 RESTOR ldx TXTTAB ; point to beginning of the program
1750 leax -1,x ; move back one (to compensate for "GETNCH")
1751 LADE8 stx DATPTR ; save as new data pointer
1752 rts
1753 ; BREAK check
1754 LADEB jsr KEYIN ; read keyboard
1755 beq LADFA ; brif no key down
1756 LADF0 cmpa #3 ; BREAK?
1757 beq STOP ; brif so - do a STOP
1758 cmpa #0x13 ; pause (SHIFT-@)?
1759 beq LADFB ; brif so
1760 sta IKEYIM ; cache key for later INKEY$ so break check doesn't break INKEY$
1761 LADFA rts
1762 LADFB jsr KEYIN ; read keyboard
1763 beq LADFB ; brif no key down
1764 bra LADF0 ; process pressed key in case BREAK or SHIFT-@ again
1765 ; END command
1766 ENDTOK jsr LA426 ; close files
1767 jsr GETCCH ; re-get input character
1768 bra LAE0B
1769 ; STOP command
1770 STOP orcc #1 ; flag "STOP"
1771 LAE0B bne LAE40 ; brif not end of statement
1772 ldx CHARAD ; save current input pointer
1773 stx TINPTR
1774 LAE11 ror ENDFLG ; save END/STOP flag (C)
1775 leas 2,s ; lose return address
1776 LAE15 ldx CURLIN ; get current input line (end of program comes here)
1777 cmpx #0xffff ; immediate mode?
1778 beq LAE22 ; brif so
1779 stx OLDTXT ; save line where we stopped executing
1780 ldx TINPTR ; get input pointer
1781 stx OLDPTR ; save location where we stopped executing
1782 LAE22 clr DEVNUM ; reset to screen/keyboard
1783 ldx #LABF2-1 ; point to BREAK message
1784 tst ENDFLG ; are we doing "BREAK"?
1785 lbpl LAC73 ; brif not
1786 jmp LAC68 ; go do the BREAK message and return to main loop
1787 ; CONT command
1788 CONT bne LAE40 ; brif not end of statement
1789 ldb #2*16 ; code for can't continue
1790 ldx OLDPTR ; get saved execution pointer
1791 lbeq LAC46 ; brif no saved pointer - raise CN error
1792 stx CHARAD ; reset input pointer
1793 ldx OLDTXT ; reset current line number
1794 stx CURLIN
1795 LAE40 rts
1796 ; CLEAR command
1797 CLEAR beq LAE6F ; brif no argument
1798 jsr LB3E6 ; evaluate string space size
1799 pshs d ; save it
1800 ldx MEMSIZ ; get memory size (top of memory)
1801 jsr GETCCH ; is there anything after the string space size?
1802 beq LAE5A ; brif not
1803 jsr LB26D ; force a comma
1804 jsr LB73D ; get top of memory value in X
1805 leax -1,x ; move back one (top of cleared space)
1806 cmpx TOPRAM ; is it within the memory available?
1807 bhi LAE72 ; brif higher than top of memory - OM error
1808 LAE5A tfr x,d ; so we can do math for checking memory usage
1809 subd ,s++ ; subtract out string space value
1810 bcs LAE72 ; brif less than 0
1811 tfr d,u ; U is bottom of cleared space
1812 subd #STKBUF ; also account for slop space
1813 bcs LAE72 ; brif less than 0
1814 subd VARTAB ; is there still room for the program?
1815 blo LAE72 ; brif not
1816 stu FRETOP ; set top of free memory
1817 stx MEMSIZ ; set size of usable memory
1818 LAE6F jmp LAD26 ; erase variables, etc.
1819 LAE72 jmp LAC44 ; raise OM error
1820 ; RUN command
1821 RUN jsr RVEC18 ; do the RAM hook dance
1822 jsr LA426 ; close any open files
1823 jsr GETCCH ; is there a line number
1824 lbeq LAD21 ; brif no line number - start from beginning
1825 jsr LAD26 ; clear variables, etc.
1826 bra LAE9F ; "GOTO" the line number
1827 ; GO command (GOTO and GOSUB)
1828 GO tfr a,b ; save TO/SUB
1829 LAE88 jsr GETNCH ; eat the TO/SUB token
1830 cmpb #0xa5 ; TO?
1831 beq LAEA4 ; brif GOTO
1832 cmpb #0xa6 ; SUB?
1833 bne LAED7 ; brif not
1834 ldb #3 ; room for 6 bytes?
1835 jsr LAC33
1836 ldu CHARAD ; get input pointer
1837 ldx CURLIN ; get line number
1838 lda #0xa6 ; flag for GOSUB frame
1839 pshs u,x,a ; set stack frame
1840 LAE9F bsr LAEA4 ; do "GOTO"
1841 jmp LAD9E ; go back to main loop
1842 ; Actual GOTO is here
1843 LAEA4 jsr GETCCH ; get current input
1844 jsr LAF67 ; convert number to binary
1845 bsr LAEEB ; move input pointer to end of statement
1846 leax 1,x ; point to start of next line
1847 ldd BINVAL ; get desired line number
1848 cmpd CURLIN ; is it beyond here?
1849 bhi LAEB6 ; brif so
1850 ldx TXTTAB ; start search at beginning of program
1851 LAEB6 jsr LAD05 ; find line number
1852 bcs LAED2 ; brif not found
1853 LAEBB leax -1,x ; move to just before start of line
1854 stx CHARAD ; reset input pointer
1855 LAEBF rts
1856 ; RETURN command
1857 RETURN bne LAEBF ; exit if argument given
1858 lda #0xff ; set VARDES to an illegal value so we ignore FOR frames
1859 sta VARDES
1860 jsr LABF9 ; look for a GOSUB frame
1861 tfr x,s ; reset stack
1862 cmpa #0xa6-0x80 ; is it a GOSUB frame?
1863 beq LAEDA ; brif so
1864 ldb #2*2 ; code for RETURN without GOSUB
1865 skip2
1866 LAED2 ldb #7*2 ; code for undefined line number
1867 jmp LAC46 ; raise error
1868 LAED7 jmp LB277 ; raise syntax error
1869 LAEDA puls a,x,u ; get back saved line number and input pointer
1870 stx CURLIN ; reset line number
1871 stu CHARAD ; reset input pointer
1872 ; DATA command
1873 DATA bsr LAEE8 ; move input pointer to end of statement
1874 skip2
1875 ; REM command (also ELSE)
1876 REM bsr LAEEB ; move input pointer to end of line
1877 stx CHARAD ; save new input pointer
1878 LAEE7 rts
1879 ; Return end of statement (LAEE8) or line (AEEB) in X
1880 LAEE8 ldb #': ; colon is statement terminator
1881 skip1lda
1882 LAEEB clrb ; make main terminator NUL
1883 stb CHARAC ; save terminator
1884 clrb ; end of line - always terminates
1885 ldx CHARAD ; get input pointer
1886 LAEF1 tfr b,a ; save secondary terminator
1887 ldb CHARAC ; get main terminator
1888 sta CHARAC ; save secondary
1889 LAEF7 lda ,x ; get input character
1890 beq LAEE7 ; brif end of line
1891 pshs b ; save terminator
1892 cmpa ,s+ ; does it match?
1893 beq LAEE7 ; brif so - bail
1894 leax 1,x ; move pointer ahead
1895 cmpa #'" ; start of string?
1896 beq LAEF1 ; brif so
1897 inca ; functon token?
1898 bne LAF0C ; brif not
1899 leax 1,x ; skip second part of function token
1900 LAF0C cmpa #0x85+1 ; IF?
1901 bne LAEF7 ; brif not
1902 inc IFCTR ; bump "IF" count
1903 bra LAEF7 ; get check another input character
1904 ; IF command
1905 IFTOK jsr LB141 ; evaluate condition
1906 jsr GETCCH ; find out what's after the conditin
1907 cmpa #0x81 ; GO?
1908 beq LAF22 ; treat same as THEN
1909 ldb #0xa7 ; make sure we have a THEN
1910 jsr LB26F
1911 LAF22 lda FP0EXP ; get true/false (false is 0)
1912 bne LAF39 ; brif condition true
1913 clr IFCTR ; reset IF counter
1914 LAF28 bsr DATA ; skip over statement
1915 tsta ; end of line?
1916 beq LAEE7 ; brif so
1917 jsr GETNCH ; get start of this statement
1918 cmpa #0x84 ; ELSE?
1919 bne LAF28 ; brif not
1920 dec IFCTR ; is it a matching ELSE?
1921 bpl LAF28 ; brif not - keep looking
1922 jsr GETNCH ; eat the ELSE
1923 LAF39 jsr GETCCH ; get current input
1924 lbcs LAEA4 ; brif numeric - to a GOTO
1925 jmp LADC6 ; let main loop interpret the next command
1926 ; ON command
1927 ON jsr LB70B ; evaluate index expression
1928 LAF45 ldb #0x81 ; make sure we have "GO"
1929 jsr LB26F
1930 pshs a ; save TO/SUB
1931 cmpa #0xa6 ; SUB?
1932 beq LAF54 ; brif so
1933 cmpa #0xa5 ; TO?
1934 LAF52 bne LAED7 ; brif not
1935 LAF54 dec FPA0+3 ; are we at the right index?
1936 bne LAF5D ; brif not
1937 puls b ; get TO/SUB token
1938 jmp LAE88 ; go do GOTO or GOSUB
1939 LAF5D jsr GETNCH ; munch a character
1940 bsr LAF67 ; parse line number
1941 cmpa #', ; is there another line following?
1942 beq LAF54 ; brif so - see if we're there yet
1943 puls b,pc ; clean up TO/SUB token and return - we fell through
1944 ; Parse a line number
1945 LAF67 ldx ZERO ; initialize line number accumulator to 0
1946 stx BINVAL
1947 LAF6B bcc LAFCE ; brif not numeric
1948 suba #'0 ; adjust to actual value of digit
1949 sta CHARAC ; save digit
1950 ldd BINVAL ; get accumulated number
1951 cmpa #24 ; will this overflow?
1952 bhi LAF52 ; brif so - raise syntax error
1953 aslb ; times 2
1954 rola
1955 aslb ; times 4
1956 rola
1957 addd BINVAL ; times 5
1958 aslb ; times 10
1959 rola
1960 addb CHARAC ; add in digit
1961 adca #0
1962 std BINVAL ; save new accumulated number
1963 jsr GETNCH ; fetch next character
1964 bra LAF6B ; process next digit
1965 ; LET command (the LET keyword requires Extended Basic)
1966 LET jsr LB357 ; evaluate destination variable
1967 stx VARDES ; save descriptor pointer
1968 ldb #0xb3 ; make sure we have =
1969 jsr LB26F
1970 lda VALTYP ; get destination variable type
1971 pshs a ; save it for later
1972 jsr LB156 ; evaluate the expression to assign
1973 puls a ; get back original variable type
1974 rora ; put type in C
1975 jsr LB148 ; make sure the current result matches the type
1976 lbeq LBC33 ; bri fnumeric - copy FPA0 to variable
1977 LAFA4 ldx FPA0+2 ; point to descriptor of replacement string
1978 ldd FRETOP ; get bottom of string space
1979 cmpd 2,x ; is the string already in string space?
1980 bhs LAFBE ; brif so
1981 cmpx VARTAB ; is the descriptor in variable space?
1982 blo LAFBE ; brif not
1983 LAFB1 ldb ,x ; get length of string
1984 jsr LB50D ; allocate space for this string
1985 ldx V4D ; get descriptor pointer back
1986 jsr LB643 ; copy string into string space
1987 ldx #STRDES ; point to temporary string descriptor
1988 LAFBE stx V4D ; save descriptor pointer
1989 jsr LB675 ; remove string from string stack if appropriate
1990 ldu V4D ; get back replacement descriptor
1991 ldx VARDES ; get target descriptor
1992 pulu a,b,y ; get string length (A) and data pointer (Y)
1993 sta ,x ; save new length
1994 sty 2,x ; save new pointer
1995 LAFCE rts
1996 ; READ and INPUT commands.
1997 LAFCF fcc '?REDO' ; The ?REDO message
1998 fcb 0x0d,0x00
1999 LAFD6 ldb #2*17 ; bad file data code
2000 tst DEVNUM ; are we reading from the keyboard?
2001 beq LAFDF ; brif so
2002 LAFDC jmp LAC46 ; raise the error
2003 LAFDF lda INPFLG ; are we doing INPUT?
2004 beq LAFEA ; brif so
2005 ldx DATTXT ; get line number where the DATA statement happened
2006 stx CURLIN ; set current line number to that so can report the correct location
2007 jmp LB277 ; raise a syntax error on bad data
2008 LAFEA ldx #LAFCF-1 ; show the ?REDO if we're doing INPUT
2009 jsr LB99C
2010 ldx TINPTR ;* reset input pointer to start of statement (this will cause the
2011 stx CHARAD ;* INPUT statement to be re-executed
2012 rts
2013 INPUT ldb #11*2 ; code for illegal direct statement
2014 ldx CURLIN ; are we in immediate mode?
2015 leax 1,x
2016 beq LAFDC ; brif so - raise ID error
2017 bsr LB002 ; go do the INPUT thing
2018 clr DEVNUM ; reset device to screen/keyboard
2019 rts
2020 LB002 cmpa #'# ; is there a device number?
2021 bne LB00F ; brif not
2022 jsr LA5A5 ; parse device number
2023 jsr LA3ED ; make sure it's valid for input
2024 jsr LB26D ; make sure we have a comma after the device number
2025 LB00F cmpa #'" ; is there a prompt string?
2026 bne LB01E ; brif not
2027 jsr LB244 ; parse the prompt string
2028 ldb #'; ; make sure we have a semicolon after the prompt
2029 jsr LB26F
2030 jsr LB99F ; print the prompt
2031 LB01E ldx #LINBUF ; point to line input buffer
2032 clr ,x ; NUL first byte to indicate no data
2033 tst DEVNUM ; is it keyboard input?
2034 bne LB049 ; brif not
2035 bsr LB02F ; read a line from the keyboard
2036 ldb #', ; put a comma at the start of the buffer
2037 stb ,x
2038 bra LB049 ; go process some input
2039 LB02F jsr LB9AF ; send a ?
2040 jsr LB9AC ; send a space
2041 LB035 jsr LA390 ; read input from the keyboard
2042 bcc LB03F ; brif not BREAK
2043 leas 4,s ; clean up stack
2044 LB03C jmp LAE11 ; go process BREAK
2045 LB03F ldb #2*23 ; input past end of file error code
2046 tst CINBFL ; was it EOF?
2047 bne LAFDC ; brif so - raise the error
2048 rts
2049 READ ldx DATPTR ; fetch current DATA pointer
2050 skip1lda ; set A to nonzero (for READ)
2051 LB049 clra ; set A to zero (for INPUT)
2052 sta INPFLG ; record whether we're doing READ or INPUT
2053 stx DATTMP ; save current input location
2054 LB04E jsr LB357 ; evaluate a variable (destination of data)
2055 stx VARDES ; save descriptor
2056 ldx CHARAD ; save interpreter input pointer
2057 stx BINVAL
2058 ldx DATTMP ; get data pointer
2059 lda ,x ; is there anything to read?
2060 bne LB069 ; brif so
2061 lda INPFLG ; is it INPUT?
2062 bne LB0B9 ; brif not
2063 jsr RVEC10 ; do the RAM hook dance
2064 jsr LB9AF ; send a ? (so subsequent lines get ??)
2065 bsr LB02F ; go read an input line
2066 LB069 stx CHARAD ; save data pointer
2067 jsr GETNCH ; fetch next data character
2068 ldb VALTYP ; do we want a number?
2069 beq LB098 ; brif so
2070 ldx CHARAD ; get input pointer
2071 sta CHARAC ; save initial character as the delimiter
2072 cmpa #'" ; do we have a string delimiter?
2073 beq LB08B ; brif so - use " as both delimiters
2074 leax -1,x ; back up input if we don't have a delimiter
2075 clra ; set delimiter to NUL (end of line)
2076 sta CHARAC
2077 jsr LA35F ; set up print parameters
2078 tst PRTDEV ; is it a file type device?
2079 bne LB08B ; brif so - use two NULs
2080 lda #': ; use colon as one delimiter
2081 sta CHARAC
2082 lda #', ; and use comma as the other
2083 LB08B sta ENDCHR ; save second terminator
2084 jsr LB51E ; parse out the string
2085 jsr LB249 ; move input pointer past the string
2086 jsr LAFA4 ; assign the string to the variable
2087 bra LB09E ; go see if there's more to read
2088 LB098 jsr LBD12 ; parse a numeric string
2089 jsr LBC33 ; assign the numbe to the variable
2090 LB09E jsr GETCCH ; get current input character
2091 beq LB0A8 ; brif end of line
2092 cmpa #', ; check for comma
2093 lbne LAFD6 ; brif not - we have bad data
2094 LB0A8 ldx CHARAD ; get current data pointer
2095 stx DATTMP ; save the data pointer
2096 ldx BINVAL ; restore the interpreter input pointer
2097 stx CHARAD
2098 jsr GETCCH ; get current input from program
2099 beq LB0D5 ; brif end of statement
2100 jsr LB26D ; make sure there's a comma between variables
2101 bra LB04E ; go read another item
2102 LB0B9 stx CHARAD ; reset input pointer
2103 jsr LAEE8 ; search for end of statement
2104 leax 1,x ; move past end of statement
2105 tsta ; was it end of line?
2106 bne LB0CD ; brif not
2107 ldb #2*3 ; code for out of data
2108 ldu ,x++ ; get pointer to next line
2109 beq LB10A ; brif end of program - raise OD error
2110 ldd ,x++ ; get line number
2111 std DATTXT ; record it for raising errors in DATA statements
2112 LB0CD lda ,x ; do we have a DATA statement?
2113 cmpa #0x86
2114 bne LB0B9 ; brif not - keep scanning
2115 bra LB069 ; go process the input
2116 LB0D5 ldx DATTMP ; get data pointer
2117 ldb INPFLG ; were we doing READ?
2118 lbne LADE8 ; brif so - save DATA pointer
2119 lda ,x ; is there something after the input in the input buffer?
2120 beq LB0E7 ; brif not - we consumed everything
2121 ldx #LB0E8-1 ; print the ?EXTRA IGNORED message
2122 jmp LB99C
2123 LB0E7 rts
2124 LB0E8 fcc '?EXTRA IGNORED'
2125 fcb 0x0d,0x00
2126 ; NEXT command
2127 NEXT bne LB0FE ; brif argument given
2128 ldx ZERO ; set to NULL descriptor pointer
2129 bra LB101 ; go process "any index will do"
2130 LB0FE jsr LB357 ; evaluate the variable
2131 LB101 stx VARDES ; save the index we're looking for
2132 jsr LABF9 ; search the stack for the matching frame
2133 beq LB10C ; brif we found a matching frame
2134 ldb #0 ; code for NEXT without FOR
2135 LB10A bra LB153 ; raise the error
2136 LB10C tfr x,s ; reset the stack to the start of the stack frame
2137 leax 3,x ; point to the STEP value
2138 jsr LBC14 ; copy the value to FPA0
2139 lda 8,s ; get step direction
2140 sta FP0SGN ; save as sign of FPA0
2141 ldx VARDES ; point to index variable
2142 jsr LB9C2 ; add (X) to FPA0 (steps the index)
2143 jsr LBC33 ; save new value to the index
2144 leax 9,s ; point to terminal condition
2145 jsr LBC96 ; compare the new index value with the terminal
2146 subb 8,s ; set B=0 if we hit the terminal (or passed it with nonzero step)
2147 beq LB134 ; brif loop complete
2148 ldx 14,s ; restore line number and input pointer to start of loop
2149 stx CURLIN
2150 ldx 16,s
2151 stx CHARAD
2152 LB131 jmp LAD9E ; return to interpretation loop
2153 LB134 leas 18,s ; remove the frame from the stack
2154 jsr GETCCH ; get character after the index
2155 cmpa #', ; do we have more indexes?
2156 bne LB131 ; brif not
2157 jsr GETNCH ; munch the comma
2158 bsr LB0FE ; go process another value
2159 ; NOTE: despite the BSR on the preceding line, execution of the NEXT command will not fall
2160 ; through this point, nor will the stack grow without bound. The BSR is required to make sure
2161 ; the stack is aligned properly for the stack search for the subsequent index variable.
2162 ;
2163 ; The following is the expression evaluation system. It has various entry points including for type
2164 ; checking. This really consists of two co-routines, one for evaluating operators and one for individual
2165 ; terms. However, it does some rather confusing stack operations so it's a bit difficult to follow
2166 ; just how some of this works.
2167 ;
2168 ; Evaluate numeric expression
2169 LB141 bsr LB156 ; evaluate an expression
2170 ; TM error if string
2171 LB143 andcc #0xfe ; clear C to indicate we want a number
2172 skip2keepc
2173 ; TM error if numeric
2174 LB146 orcc #1 ; set C to indicate we want a string
2175 ; TM error if: C = 1 and number, OR C = 0 and string
2176 LB148 tst VALTYP ; set flags on the current value to (doesn't change C)
2177 bcs LB14F ; brif we want a string
2178 bpl LB0E7 ; brif we have a number (we want a number)
2179 skip2
2180 LB14F bmi LB0E7 ; brif we have a string (we want a string)
2181 LB151 ldb #12*2 ; code for TM error
2182 LB153 jmp LAC46 ; raise the error
2183 ; The general expression evaluation entry point
2184 LB156 bsr LB1C6 ; back up input pointer to compensate for GETNCH below
2185 LB158 clra ; set operator precedence to 0 (no previous operator)
2186 skip2
2187 LB15A pshs b ; save relational operator flags
2188 pshs a ; save previous operator precedence
2189 ldb #1 ; make sure we aren't overflowing the stack
2190 jsr LAC33
2191 jsr LB223 ; go evaluate the first term
2192 LB166 clr TRELFL ; flag no relational operators seen
2193 LB168 jsr GETCCH ; get input character
2194 LB16A suba #0xb2 ; token for > (lowest relational operator)
2195 blo LB181 ; brif below relational operators
2196 cmpa #3 ; there are three relational operators, is it one?
2197 bhs LB181 ; brif not
2198 cmpa #1 ; set C if >
2199 rola ; shift C into bit 0 (4: <, 2: =, 1: >)
2200 eora TRELFL ; flip the bit for this operator
2201 cmpa TRELFL ; did the result get lower?
2202 blo LB1DF ; brif so - we have a duplicate so raise an error
2203 sta TRELFL ; save new operator flags
2204 jsr GETNCH ; munch the operator
2205 bra LB16A ; go see if we have another one
2206 LB181 ldb TRELFL ; do we have a relational comparison?
2207 bne LB1B8 ; brif so
2208 lbcc LB1F4 ; brif the token is above the relational operators
2209 adda #7 ; put operators starting at 0
2210 bhs LB1F4 ; brif we're above 0 - it's an operator, Jim
2211 adca VALTYP ; add carry, numeric flag, and modified token number
2212 lbeq LB60F ; brif we have string and A is + - do concatenation
2213 adca #-1 ; restore operator number
2214 pshs a ; save operator number
2215 asla ; times 2
2216 adda ,s+ ; and times 3 (3 bytes per entry)
2217 ldx #LAA51 ; point to operator pecedence and jump table
2218 leax a,x ; point to correct entry
2219 LB19F puls a ; get precedence of previous operation
2220 cmpa ,x ; is hit higher (or same) than the current one?
2221 bhs LB1FA ; brif so - we need to process that operator
2222 bsr LB143 ; TM error if we have a string
2223 LB1A7 pshs a ; save previous operation precedence
2224 bsr LB1D4 ; push operator handler address and FPA0 onto the stack
2225 ldx RELPTR ; get pointer to arithmetic/logical table entry for last operation
2226 puls a ; get back precedence
2227 bne LB1CE ; brif we had a relational operation
2228 tsta ; check precedence of previous operation
2229 lbeq LB220 ; brif end of expression
2230 bra LB203 ; go handle operation
2231 LB1B8 asl VALTYP ; get type of value to C
2232 rolb ; mix it in to bit 0 of relational flags
2233 bsr LB1C6 ; back up input pointer
2234 ldx #LB1CB ; point to relational operator precedence and handler
2235 stb TRELFL ; save relational comparison flags
2236 clr VALTYP ; result will be numeric
2237 bra LB19F ; to process the operation
2238 LB1C6 ldx CHARAD ; get input pointer
2239 jmp LAEBB ; back it up one and put it back
2240 LB1CB fcb 0x64 ; precedence of relational comparison
2241 fdb LB2F4 ; handler address for relational comparison
2242 LB1CE cmpa ,x ; is last done operation higher (or same) precedence?
2243 bhs LB203 ; brif so - go process it
2244 bra LB1A7 ; go push things on the stack and process this operation otherwise
2245 LB1D4 ldd 1,x ; get address of operatorroutine
2246 pshs d ; save it
2247 bsr LB1E2 ; push FPA0 onto the stack
2248 ldb TRELFL ; get back relational operator flags
2249 lbra LB15A ; go evaluate another operation
2250 LB1DF jmp LB277 ; raise a syntax error
2251 LB1E2 ldb FP0SGN ; get sign of FPA0
2252 lda ,x ; get precedence of this operation
2253 LB1E6 puls y ; get back original caller
2254 pshs b ; save sign
2255 LB1EA ldb FP0EXP ; get exponent
2256 ldx FPA0 ; get mantissa
2257 ldu FPA0+2
2258 pshs u,x,b ; stow FPA0 sign and mantissa
2259 jmp ,y ; return to caller
2260 LB1F4 ldx ZERO ; point to dummy value
2261 lda ,s+ ; get precedence of previous operation (and set flags)
2262 beq LB220 ; brif end of expression
2263 LB1FA cmpa #0x64 ; relational operation?
2264 beq LB201 ; brif so
2265 jsr LB143 ; type mismatch if string
2266 LB201 stx RELPTR ; save pointer to operator routine
2267 LB203 puls b ; get relational flags
2268 cmpa #0x5a ; NOT operation?
2269 beq LB222 ; brif so (it was unary)
2270 cmpa #0x7d ; unary negation?
2271 beq LB222 ; brif so
2272 lsrb ; shift value type flag out of relational flags
2273 stb RELFLG ; save relational operator flag
2274 puls a,x,u ; get FP value back
2275 sta FP1EXP ; set exponent and mantissa in FPA1
2276 stx FPA1
2277 stu FPA1+2
2278 puls b ; and the sign
2279 stb FP1SGN
2280 eorb FP0SGN ; set RESSGN if the two operand signs differ
2281 stb RESSGN
2282 LB220 ldb FP0EXP ; get exponent of FPA0
2283 LB222 rts ; return or transfer control to operator handler routine
2284 LB223 jsr RVEC15 ; do the RAM hook dance
2285 clr VALTYP ; set type to numeric
2286 LB228 jsr GETNCH ; get first character in the term
2287 bcc LB22F ; brif not numeric
2288 LB22C jmp LBD12 ; parse a number (and return)
2289 LB22F jsr LB3A2 ; set carry if not alpha
2290 bcc LB284 ; brif alpha character (variable)
2291 cmpa #'. ; decimal point?
2292 beq LB22C ; brif so - evaluate number
2293 cmpa #0xac ; minus?
2294 beq LB27C ; brif so - process unary negation
2295 cmpa #0xab ; plus?
2296 beq LB228 ; brif so - ignore unary "posation"
2297 cmpa #'" ; string delimiter?
2298 bne LB24E ; brif not
2299 LB244 ldx CHARAD ; get input pointer
2300 jsr LB518 ; go parse the string
2301 LB249 ldx COEFPT ; get address of end of string
2302 stx CHARAD ; move input pointer past string
2303 rts
2304 LB24E cmpa #0xa8 ; NOT?
2305 bne LB25F ; brif not
2306 lda #0x5a ; precedence of unary NOT
2307 jsr LB15A ; process the operand of NOT
2308 jsr INTCNV ; convert to integer in D
2309 coma ; do a bitwise complement
2310 comb
2311 jmp GIVABF ; resturn the result
2312 LB25F inca ; is it a function token?
2313 beq LB290 ; brif so
2314 LB262 bsr LB26A ; only other legal thing must be a (expr)
2315 jsr LB156 ; evaluate parentheticized expression
2316 LB267 ldb #') ; force a )
2317 skip2
2318 LB26A ldb #'( ; force a (
2319 skip2
2320 LB26D ldb #', ; force a ,
2321 LB26F cmpb [CHARAD] ; does character match?
2322 bne LB277 ; brif not
2323 jmp GETNCH ; each the character and return the next
2324 LB277 ldb #2*1 ; raise syntax error
2325 jmp LAC46
2326 LB27C lda #0x7d ; unary negation precedence
2327 jsr LB15A ; evaluate argument
2328 jmp LBEE9 ; flip sign of FPA0 and return
2329 LB284 jsr LB357 ; evaluate variable
2330 LB287 stx FPA0+2 ; save descriptor address in FPA0
2331 lda VALTYP ; test variable type
2332 bne LB222 ; brif string - we're done
2333 jmp LBC14 ; copy FP number from (X) into FPA0
2334 LB290 jsr GETNCH ; get the actual token number
2335 tfr a,b ; save it (for offsetting X)
2336 lslb ; two bytes per jump table entry (and lose high bit)
2337 jsr GETNCH ; eat the token byte
2338 cmpb #2*19 ; is it a valid token for Color Basic?
2339 bls LB29F ; brif so
2340 jmp [COMVEC+18] ; transfer control to Extended Basic if not
2341 LB29F pshs b ; save jump table offset
2342 cmpb #2*14 ; does it expect a numeric argument?
2343 blo LB2C7 ; brif so
2344 cmpb #2*18 ; does it need no arguments?
2345 bhs LB2C9 ; brif so
2346 bsr LB26A ; force a (
2347 lda ,s ; get token value
2348 cmpa #2*17 ; is it POINT?
2349 bhs LB2C9 ; brif so
2350 jsr LB156 ; evaluate first argument string
2351 bsr LB26D ; force a comma
2352 jsr LB146 ; TM error if string
2353 puls a ; get token value
2354 ldu FPA0+2 ; get string descriptor
2355 pshs u,a ; now we save the first string argument and the token value
2356 jsr LB70B ; evaluate first numeric argument
2357 puls a ; get back token value
2358 pshs b,a ; save second argument and token value
2359 fcb 0x8e ; opcode of LDX immediate (skips two bytes)
2360 LB2C7 bsr LB262 ; force a (
2361 LB2C9 puls b ; get offset
2362 ldx COMVEC+8 ; get jump table pointer
2363 abx ; add offset into table
2364 jsr [,x] ; go process function
2365 jmp LB143 ; make sure result is numeric
2366 ; operator OR
2367 LB2D4 skip1lda ; set flag to nonzero to signal OR
2368 ; operator AND
2369 LB2D5 clra ; set flag to zero to signal AND
2370 sta TMPLOC ; save AND/OR flag
2371 jsr INTCNV ; convert second argument to intenger
2372 std CHARAC ; save it
2373 jsr LBC4A ; move first argument to FPA0
2374 jsr INTCNV ; convert first argument to integer
2375 tst TMPLOC ; is it AND or OR?
2376 bne LB2ED ; brif OR
2377 anda CHARAC ; do the bitwise AND
2378 andb ENDCHR
2379 bra LB2F1 ; finish up
2380 LB2ED ora CHARAC ; do the bitwise OR
2381 orb ENDCHR
2382 LB2F1 jmp GIVABF ; return integer result
2383 ; relational comparision operators
2384 LB2F4 jsr LB148 ; TM error if type mismatch
2385 BNE LB309 ; brif we have a string comparison
2386 lda FP1SGN ; pack FPA1
2387 ora #0x7f
2388 anda FPA1
2389 sta FPA1
2390 ldx #FP1EXP ; point to packed FPA1
2391 jsr LBC96 ; compare FPA0 to FPA1
2392 bra LB33F ; handle truth comparison
2393 LB309 clr VALTYP ; the result of a comparison is always a number
2394 dec TRELFL ; remove the string flag from the comparison data
2395 jsr LB657 ; get string details for second argument
2396 stb STRDES ; save them in the temporary string descriptor
2397 stx STRDES+2
2398 ldx FPA1+2 ; get pointer to first argument descriptor
2399 jsr LB659 ; get string details for second argument
2400 lda STRDES ; get length of second argument
2401 pshs b ; save length of first argument
2402 suba ,s+ ; now A is the difference in string lengths
2403 beq LB328 ; brif string lengths are equal
2404 lda #1 ; flag for second argument is longer than first
2405 bcc LB328 ; brif second string is longer than first
2406 ldb STRDES ; get length of second string (shorter)
2407 nega ; invert default comparison result
2408 LB328 sta FP0SGN ; save default truth flag
2409 ldu STRDES+2 ; get pointer to start of second string
2410 incb ; compensate for DECB
2411 LB32D decb ; have we compared everything?
2412 bne LB334 ; brif not
2413 ldb FP0SGN ; get default truth value
2414 bra LB33F ; decide comparison truth
2415 LB334 lda ,x+ ; get byte from first argument
2416 cmpa ,u+ ; compare with second argument
2417 beq LB32D ; brif equal - keep comparing
2418 ldb #0xff ; negative if first string is > second
2419 bcc LB33F ; brif string A > string B
2420 negb ; invert result
2421 LB33F addb #1 ; convert to 0,1,2
2422 rolb ; shift left - now it's 4,2,1 for <, =, >
2423 andb RELFLG ; keep only the truth we care about
2424 beq LB348 ; brif no matching bits - it's false
2425 ldb #0xff ; set true
2426 LB348 jmp LBC7C ; convert result to FP and return it
2427 ; DIM command
2428 LB34B jsr LB26D ; make sure there's a comma between variables
2429 DIM ldb #1 ; flag that we're dimensioning
2430 bsr LB35A ; go allocate the variable
2431 jsr GETCCH ; are we done?
2432 bne LB34B ; brif not
2433 rts
2434 ; This routine parses a variable. For scalars, it will return a NULL string or 0 value number
2435 ; if it is called from "evaluate term". Otherwise, it allocates the variable. For arrays, it will
2436 ; allocate a default sized array if dimensioning is not underway and then attempt to look up
2437 ; the requested coordinates in that array. Otherwise, it will allocate an array based on the
2438 ; specified dimension values.
2439 LB357 clrb ; flag that we're not setting up an array
2440 jsr GETCCH
2441 LB35A stb DIMFLG ; save dimensioning flag
2442 sta VARNAM ; save first character of variable name
2443 jsr GETCCH ; get input character (why? we already have it)
2444 bsr LB3A2 ; set carry if not alpha
2445 lbcs LB277 ; brif our variable doesn't start with a letter
2446 clrb ; default second variable character to NUL
2447 stb VALTYP ; set value type to numeric
2448 jsr GETNCH ; get second character
2449 bcs LB371 ; brif numeric - numbers are allowed
2450 bsr LB3A2 ; set carry if not alpha
2451 bcs LB37B ; brif not alpha
2452 LB371 tfr a,b ; save set second character of variable name
2453 LB373 jsr GETNCH ; get an input character
2454 bcs LB373 ; brif numeric - still in variable name
2455 bsr LB3A2 ; set carry if not alpha
2456 bcc LB373 ; brif alpha - still in variable name
2457 LB37B cmpa #'$ ; do we have the string sigil?
2458 bne LB385 ; brif not
2459 com VALTYP ; set value type to string
2460 addb #0x80 ; set bit 7 of second variable character to indicate string
2461 jsr GETNCH ; eat the sigil
2462 LB385 stb VARNAM+1 ; save second variable name character
2463 ora ARYDIS ; merge array disable flag (will set bit 7 of input character if no arrays)
2464 suba #'( ; do we have a subscript?
2465 lbeq LB404 ; brif so
2466 clr ARYDIS ; disable the array disable flag - it's single use
2467 ldx VARTAB ; point to the start of the variable table
2468 ldd VARNAM ; get variable name
2469 LB395 cmpx ARYTAB ; are we at the top of the variable table?
2470 beq LB3AB ; brif so
2471 cmpd ,x++ ; does the variable name match (and move pointer to variable data)
2472 beq LB3DC ; brif so
2473 leax 5,x ; move to next table entry
2474 bra LB395 ; see if we have a match
2475 ; Set carry if not upper case alpha
2476 LB3A2 cmpa #'A ; set C if less than A
2477 bcs LB3AA ; brif less than A
2478 suba #'Z+1 ; set C if greater than Z
2479 suba #-('Z+1)
2480 LB3AA rts
2481 LB3AB ldx #ZERO ; point to empty location (NULL/0 value)
2482 ldu ,s ; get caller address
2483 cmpu #LB287 ; coming from "evaluate term"?
2484 beq LB3DE ; brif so - don't allocate
2485 ldd ARYEND ; get end of arrays
2486 std V43 ; save as top of source block
2487 addd #7 ; 7 bytes per scalar entry
2488 std V41 ; save as top of destination block
2489 ldx ARYTAB ; get bottom of arrays
2490 stx V47 ; save as bottom of source block
2491 jsr LAC1E ; move the arrays up to make a hole
2492 ldx V41 ; get new top of arrays
2493 stx ARYEND ; set new end of arrays
2494 ldx V45 ; get bottom of destination block
2495 stx ARYTAB ; set as new start of arrays
2496 ldx V47 ; get old end of variables
2497 ldd VARNAM ; get name of variable
2498 std ,x++ ; set variable name and advance X to the value
2499 clra ; zero out the variable value
2500 clrb
2501 std ,x
2502 std 2,x
2503 sta 4,x
2504 LB3DC stx VARPTR ; save descriptor address of return value
2505 LB3DE rts
2506 ; Various integer conversion routines
2507 LB3DF fcb 0x90,0x80,0x00,0x00,0x00 ; FP constant -32768
2508 LB3E4 jsr GETNCH ; fetch input character
2509 LB3E6 jsr LB141 ; evaluate numeric expression
2510 LB3E9 lda FP0SGN ; get sign of value
2511 bmi LB44A ; brif negative (raise FC error)
2512 INTCNV lda FP0EXP ; get exponent
2513 cmpa #0x90 ; is it within the range for a 16 bit integer?
2514 blo LB3FE ; brif smaller than 32768
2515 ldx #LB3DF ; point to -32678 constant
2516 jsr LBC96 ; is FPA0 equal to -32768?
2517 bne LB44A ; brif not - magnitude is too far negative
2518 LB3FE jsr LBCC8 ; move binary point to the right of FPA0 and correct sign
2519 ldd FPA0+2 ; get the resulting integer
2520 rts
2521 LB404 ldb DIMFLG ; get dimensioning flag
2522 lda VALTYP ; get type of variable
2523 pshs b,a ; save them (to avoid issues while evaluating dimension values)
2524 clrb ; reset dimension counter
2525 LB40A ldx VARNAM ; get variable name
2526 pshs x,b ; save dimension counter and variable name
2527 bsr LB3E4 ; evaluate a dimension value (and skip either ( or ,)
2528 puls b,x,y ; get variable name, dimension counter, and dimensioning/type flag
2529 stx VARNAM ; restore variable name
2530 ldu FPA0+2 ; get dimension size/index
2531 pshs u,y ; save dimension size and dimensioning/type flag
2532 incb ; bump dimension counter
2533 jsr GETCCH ; get what's after the dimension count
2534 cmpa #', ; do we have another dimension?
2535 beq LB40A ; brif so - parse it
2536 stb TMPLOC ; save dimension counter
2537 jsr LB267 ; make sure we have a )
2538 puls a,b ; get back variable type and dimensioning flag
2539 sta VALTYP ; restore variable type
2540 stb DIMFLG ; restore dimensioning flag
2541 ldx ARYTAB ; get start of arrays
2542 LB42A cmpx ARYEND ; are we at the end of the array table
2543 beq LB44F ; brif so
2544 ldd VARNAM ; get variable name
2545 cmpd ,x ; does it match?
2546 beq LB43B ; brif so
2547 ldd 2,x ; get length of this array
2548 leax d,x ; move to next array
2549 bra LB42A ; go check another entry
2550 LB43B ldb #2*9 ; code for redimensioned array error
2551 lda DIMFLG ; are we dimensioning?
2552 bne LB44C ; brif so - raise error
2553 ldb TMPLOC ; get number of dimensions given
2554 cmpb 4,x ; does it match?
2555 beq LB4A0 ; brif so
2556 LB447 ldb #8*2 ; raise "bad subscript"
2557 skip2
2558 LB44A ldb #4*2 ; raise "illegal function call"
2559 LB44C jmp LAC46 ; raise error
2560 LB44F ldd #5 ; 5 bytes per array entry
2561 std COEFPT ; initialize array size to entry size
2562 ldd VARNAM ; get variable name
2563 std ,x ; set array name
2564 ldb TMPLOC ; get dimension count
2565 stb 4,x ; set dimension count
2566 jsr LAC33 ; make sure we haven't overflowed memory
2567 stx V41 ; save array descriptor address
2568 LB461 ldb #11 ; default dimension value (zero-based, gives max index of 10)
2569 clra ; zero extend (??? why not LDD above?)
2570 tst DIMFLG ; are we dimensioning?
2571 beq LB46D ; brif not
2572 puls a,b ; get dimension size
2573 addd #1 ; account for zero based indexing
2574 LB46D std 5,x ; save dimension size
2575 bsr LB4CE ; multiply by accumulated array size
2576 std COEFPT ; save new array size
2577 leax 2,x ; move to next dimension
2578 dec TMPLOC ; have we done all dimensions?
2579 bne LB461 ; brif not
2580 stx TEMPTR ; save end of array descriptor (minus 5)
2581 addd TEMPTR ; add total size of array to address of descriptor
2582 lbcs LAC44 ; brif it overflows memory
2583 tfr d,x ; save end of array for later
2584 jsr LAC37 ; does array fit in memory?
2585 subd #STKBUF-5 ; subtract out the "stack fudge factor" but add 5 to the result
2586 std ARYEND ; save new end of arrays
2587 clra ; set up for clearing
2588 LB48C leax -1,x ; move back one
2589 sta 5,x ; blank out a byte in the array data
2590 cmpx TEMPTR ; have we reached the array header?
2591 bne LB48C ; brif not
2592 ldx V41 ; get address of start of descriptor
2593 lda ARYEND ; get MSB of end of array back (B still has LSB)
2594 subd V41 ; subtract start of descriptor
2595 std 2,x ; save length of array in array header
2596 lda DIMFLG ; are we dimensioning?
2597 bne LB4CD ; brif so - we're done
2598 LB4A0 ldb 4,x ; get number of dimensions
2599 stb TMPLOC ; initialize counter
2600 clra ; initialize accumulated offset
2601 clrb
2602 LB4A6 std COEFPT ; save accumulated offset
2603 puls a,b ; get desired index
2604 std FPA0+2 ; save it
2605 cmpd 5,x ; is it in range for this dimension?
2606 bhs LB4EB ; brif not
2607 ldu COEFPT ; get accumulated offset
2608 beq LB4B9 ; brif first dimension
2609 bsr LB4CE ; multiply accumulated offset by dimension length
2610 addd FPA0+2 ; add in offset into this dimension
2611 LB4B9 leax 2,x ; move to next dimension in header
2612 dec TMPLOC ; done all dimensions?
2613 bne LB4A6 ; brif not
2614 std ,--s ; save D for multiply by 5 (should be pshs d)
2615 aslb ; times 2
2616 rola
2617 aslb ; times 4
2618 rola
2619 addd ,s++ ; times 5
2620 leax d,x ; add in offset from start of array data
2621 leax 5,x ; offset to end of header
2622 stx VARPTR ; save pointer to element data
2623 LB4CD rts
2624 ; multiply 16 bit number at 5,x by the 16 bit number in COEFPT; return result in D; BS error if carry
2625 LB4CE lda #16 ; 16 shifts to do a multiply
2626 sta V45 ; save shift counter
2627 ldd 5,x ; get multiplier
2628 std BOTSTK ; save it
2629 clra ; zero out product
2630 clrb
2631 LB4D8 aslb ; shift product left
2632 rola
2633 bcs LB4EB ; brif we have a carry
2634 asl COEFPT+1 ; shift other factor left
2635 rol COEFPT
2636 bcc LB4E6 ; brif no carry - this bit position is 0
2637 addd BOTSTK ; add in multiplier at this bit position
2638 bcs LB4EB ; brif carry - do an error
2639 LB4E6 dec V45 ; have we done all 16 bits?
2640 bne LB4D8 ; brif not
2641 rts
2642 LB4EB jmp LB447 ; raise a BS error
2643 ; MEM function
2644 ; BUG: this doesn't account for the STKBUF fudge factor used for memory availability checks
2645 MEM tfr s,d ; get stack pointer where we can do math
2646 subd ARYEND ; calculate number of bytes between the stack and the top of arrays
2647 skip1 ; return result
2648 ; Convert unsigned value in B to FP
2649 LB4F3 clra ; zero extend
2650 ; Convert signed value in D to FP
2651 GIVABF clr VALTYP ; set value type to numeric
2652 std FPA0 ; save value in FPA0
2653 ldb #0x90 ; exponent for top two bytes to be an integer
2654 jmp LBC82 ; finish conversion to integer
2655 ; STR$ function
2656 STR jsr LB143 ; make sure we have a number
2657 ldu #STRBUF+2 ; convert FP number to string in temporary string buffer
2658 jsr LBDDC
2659 leas 2,s ; don't return to the function evaluator (which will do a numeric type check)
2660 ldx #STRBUF+1 ; point to number string
2661 bra LB518 ; to stash the string in string space and return to the "evaluate term" caller
2662 ; Reserve B bytes of string space. Return start in X and FRESPC
2663 LB50D stx V4D ; save X somewhere in case the caller needs it
2664 LB50F bsr LB56D ; allocate string space
2665 LB511 stx STRDES+2 ; save pointer to allocated space in the temporary descriptor
2666 stb STRDES ; save length in the temporary descriptor
2667 rts
2668 LB516 leax -1,x ; move pointer back one (to compensate for the increment below)
2669 ; Scan from X until either NUL or one of the string terminators is found
2670 LB518 lda #'" ; set terminator to be string delimiter
2671 LB51A sta CHARAC ; set both delimiters
2672 sta ENDCHR
2673 LB51E leax 1,x ; move to next character
2674 stx RESSGN ; save start of string
2675 stx STRDES+2 ; save start of string in the temporary string descriptor
2676 ldb #-1 ; initialize length counter to -1 (compensate for initial INCB)
2677 LB526 incb ; bump string length
2678 lda ,x+ ; get character from string
2679 beq LB537 ; brif end of line
2680 cmpa CHARAC ; is it delimiter #1?
2681 beq LB533 ; brif so
2682 cmpa ENDCHR ; is it delimiter #2?
2683 bne LB526 ; brif not - keep scanning
2684 LB533 cmpa #'" ; string delimiter?
2685 beq LB539 ; brif so - don't move pointer back
2686 LB537 leax -1,x ; move pointer back (so we don't consume the delimiter)
2687 LB539 stx COEFPT ; save end of string address
2688 stb STRDES ; save string length
2689 ldu RESSGN ; get start of string
2690 cmpu #STRBUF+2 ; is it at the start of the string buffer?
2691 bhi LB54C ; brif so - don't copy it to string space
2692 bsr LB50D ; allocate string space
2693 ldx RESSGN ; point to beginning of the string
2694 jsr LB645 ; copy string data (B bytes) from (X) to (FRESPC)
2695 ; Put temporary string descriptor on the string stack
2696 LB54C ldx TEMPPT ; get top of string stack
2697 cmpx #CFNBUF ; is the string stack full?
2698 bne LB558 ; brif not
2699 ldb #15*2 ; code for "string formula too complex"
2700 LB555 jmp LAC46 ; raise error
2701 LB558 lda STRDES ; get string length
2702 sta 0,x ; save it in the string stack descriptor
2703 ldd STRDES+2 ; get string data pointer
2704 std 2,x ; save in string stack descriptor
2705 lda #0xff ; set value type to string
2706 sta VALTYP
2707 stx LASTPT ; set pointer to last used entry on the string stack
2708 stx FPA0+2 ; set pointer to descriptor in the current evaluation value
2709 leax 5,x ; advance string stack pointer
2710 stx TEMPPT
2711 rts
2712 ; Reserve B bytes in string space. If there isn't enough space, try compacting string space and
2713 ; then try the allocation again. If it still fails, raise OS error.
2714 LB56D clr GARBFL ; flag that compaction not yet done
2715 LB56F clra ; zero extend the length
2716 pshs d ; save requested string length
2717 ldd STRTAB ; get current bottom of strings
2718 subd ,s+ ; calculate new bottom of strings and remove zero extension
2719 cmpd FRETOP ; does the string fit?
2720 blo LB585 ; brif not - try compaction
2721 std STRTAB ; save new bottom of strings
2722 ldx STRTAB ; get bottom of strings
2723 leax 1,x ; now X points to the real start of the allocated space
2724 stx FRESPC ; save the string pointer
2725 puls b,pc ; restore length and return
2726 LB585 ldb #2*13 ; code for out of string space
2727 com GARBFL ; have we compacted string space yet?
2728 beq LB555 ; brif so - raise error
2729 bsr LB591 ; compact string space
2730 puls b ; get back string length
2731 bra LB56F ; go try allocation again
2732 ; Compact string space
2733 ; This is an O(n^2) algorithm. It first searches all extant strings for the highest address data pointer
2734 ; that hasn't already been moved into the freshly compacted string space. If then moves that string data
2735 ; up to the highest address it can go to. It repeats this process over and over until it finds no string
2736 ; that isn't already in the compacted space. While doing this, it has to search all strings on the string
2737 ; stack (this is why the string stack is needed - so we can track anonymous strings), all scalar string
2738 ; variables, and *every* entry in every string array.
2739 LB591 ldx MEMSIZ ; get to of string space
2740 LB593 stx STRTAB ; save top of uncompacted stringspace
2741 clra ; zero out D and reset pointer to discovered variable to NULL
2742 clrb
2743 std V4B
2744 ldx FRETOP ; point to bottom of string space
2745 stx V47 ; save as lowest match address (match will be higher)
2746 ldx #STRSTK ; point to start of string stack
2747 LB5A0 cmpx TEMPPT ; are we at the top of the string stack?
2748 beq LB5A8 ; brif so - done with the string stack
2749 bsr LB5D8 ; check for string in uncompacted space (and advance pointer)
2750 bra LB5A0 ; check another on the string stack
2751 LB5A8 ldx VARTAB ; point to start of scalar variables
2752 LB5AA cmpx ARYTAB ; end of scalars?
2753 beq LB5B2 ; brif so
2754 bsr LB5D2 ; check for string in uncompacted space and advance pointer
2755 bra LB5AA ; check another variable
2756 LB5B2 stx V41 ; save address of end of variables (address of first array)
2757 LB5B4 ldx V41 ; get start of the next array
2758 LB5B6 cmpx ARYEND ; end of arrays?
2759 beq LB5EF ; brif so
2760 ldd 2,x ; get length of array
2761 addd V41 ; add to start of array
2762 std V41 ; save address of next array
2763 lda 1,x ; get second character of variable name
2764 bpl LB5B4 ; brif numeric
2765 ldb 4,x ; get number of dimensions
2766 aslb ; two bytes per dimension size
2767 addb #5 ; add in fixed overhead for array descriptor
2768 abx ; now X points to first array element
2769 LB5CA cmpx V41 ; at the start of the next array?
2770 beq LB5B6 ; brif so - go handle another array
2771 bsr LB5D8 ; check for string in uncompacted space (and advance pointer)
2772 bra LB5CA ; process next array element
2773 LB5D2 lda 1,x ; get second character of variable name
2774 leax 2,x ; move to variable data
2775 bpl LB5EC ; brif numeric
2776 LB5D8 ldb ,x ; get length of string
2777 beq LB5EC ; brif NULL - don't need to check data pointer
2778 ldd 2,x ; get data pointer
2779 cmpd STRTAB ; is it in compacted string space?
2780 bhi LB5EC ; brif so
2781 cmpd V47 ; is it better match than previous best?
2782 bls LB5EC ; brif not
2783 stx V4B ; save descriptor address of best match
2784 std V47 ; save new best data pointer match
2785 LB5EC leax 5,x ; move to next descriptor
2786 LB5EE rts
2787 LB5EF ldx V4B ; get descriptor address of the matched string
2788 beq LB5EE ; brif we didn't find one - we're done
2789 clra ; zero extend length
2790 ldb ,x ; get string length
2791 decb ; subtract one (we won't have a NULL string here)
2792 addd V47 ; now D points to the address of the end of the string data
2793 std V43 ; save as top address of move
2794 ldx STRTAB ; set top of uncompacted space as destination
2795 stx V41
2796 jsr LAC20 ; move string to top of uncompactedspace
2797 ldx V4B ; point to string descriptor
2798 ldd V45 ; get new data pointer address
2799 std 2,x ; update descriptor
2800 ldx V45 ; get bottom of copy destination
2801 leax -1,x ; move back below it
2802 jmp LB593 ; go search for another string to move (and set new bottom of string space)
2803 ; Concatenate two strings. We come here directly from the operator handler rather than via a JSR.
2804 LB60F ldd FPA0+2 ; get string descriptor for the first string
2805 pshs d ; save it
2806 jsr LB223 ; evaluate a second string (concatenation is left associative)
2807 jsr LB146 ; make sure we have a string
2808 puls x ; get back first string descriptor
2809 stx RESSGN ; save it
2810 ldb ,x ; get length of first string
2811 ldx FPA0+2 ; get pointer to second string
2812 addb ,x ; add length of second string
2813 bcc LB62A ; brif combined length is OK
2814 ldb #2*14 ; raise string too long error
2815 jmp LAC46
2816 LB62A jsr LB50D ; reserve room for new string
2817 ldx RESSGN ; get descriptor address of the first string
2818 ldb ,x ; get length of first string
2819 bsr LB643 ; copy it to string space
2820 ldx V4D ; get descriptor address of second string
2821 bsr LB659 ; get string details for second string
2822 bsr LB645 ; copy second string into new string space
2823 ldx RESSGN ; get pointer to first string
2824 bsr LB659 ; remove it from the string stack if possible
2825 jsr LB54C ; put new string on the string stack
2826 jmp LB168 ; return to expression evaluator
2827 ; Copy B bytes to space pointed to by FRESPC
2828 LB643 ldx 2,x ; get source address from string descriptor
2829 LB645 ldu FRESPC ; get destination address
2830 incb ; compensate for decb
2831 bra LB64E ; do the copy
2832 LB64A lda ,x+ ; copy a byte
2833 sta ,u+
2834 LB64E decb ; done yet?
2835 bne LB64A ; brif not
2836 stu FRESPC ; save destination pointer
2837 rts
2838 ; Fetch details of string in FPA0+2 and remove from the string stack if possible
2839 LB654 jsr LB146 ; make sure we have a string
2840 LB657 ldx FPA0+2 ; get descriptor pointer
2841 LB659 ldb ,x ; get length of string
2842 bsr LB675 ; see if it's at the top of the string stack and remove it if so
2843 bne LB672 ; brif not removed
2844 ldx 5+2,x ; get start address of string just removed
2845 leax -1,x ; move pointer down 1
2846 cmpx STRTAB ; is it at the bottom of string space?
2847 bne LB66F ; brif not
2848 pshs b ; save length
2849 addd STRTAB ; add length to start of strings (A was cleared previously)
2850 std STRTAB ; save new string space start (deallocated space for this string)
2851 puls b ; get back string length
2852 LB66F leax 1,x ; restore pointer to pointing at the actual string data
2853 rts
2854 LB672 ldx 2,x ; get data pointer for the string
2855 rts
2856 ; Remove string pointed to by X from the string stack if it is at the top of the stack; return with
2857 ; A clear and Z set if string removed
2858 LB675 cmpx LASTPT ; is it at the top of the string stack?
2859 bne LB680 ; brif not - do nothing
2860 stx TEMPPT ; save new top of stack
2861 leax -5,x ; move the "last" pointer back as well
2862 stx LASTPT
2863 clra ; flag string removed
2864 LB680 rts
2865 ; LEN function
2866 LEN bsr LB686 ; get string details
2867 LB683 jmp LB4F3 ; return unsigned length in B
2868 LB686 bsr LB654 ; get string details and remove from string stack
2869 clr VALTYP ; set value type to numeric
2870 tstb ; set flags according to length
2871 rts
2872 ; CHR$ function
2873 CHR jsr LB70E ; get 8 bit unsigned integer to B
2874 LB68F ldb #1 ; allocate a one byte string
2875 jsr LB56D
2876 lda FPA0+3 ; get character code
2877 jsr LB511 ; save reserved string details in temp descriptor
2878 sta ,x ; put character in string
2879 LB69B leas 2,s ; don't go back to function handler - avoid numeric type check
2880 LB69D jmp LB54C ; return temporary string on string stack
2881 ; ASC function
2882 ASC bsr LB6A4 ; get first character of argument
2883 bra LB683 ; return unsigned code in B
2884 LB6A4 bsr LB686 ; fetch string details
2885 beq LB706 ; brif NULL string
2886 ldb ,x ; get character at start of string
2887 rts
2888 ; LEFT$ function
2889 LEFT bsr LB6F5 ; get arguments from the stack
2890 LB6AD clra ; clear pointer offset (set to start of string)
2891 LB6AE cmpb ,x ; are we asking for more characters than there are in the string?
2892 bls LB6B5 ; brif not
2893 ldb ,x ; only return the number that are in the string
2894 clra ; force starting offset to be the start of the string
2895 LB6B5 pshs b,a ; save offset and length
2896 jsr LB50F ; reserve space in string space
2897 ldx V4D ; point to original string descriptor
2898 bsr LB659 ; get string details
2899 puls b ; get string offset
2900 abx ; now X points to the start of the data to copy
2901 puls b ; get length of copy
2902 jsr LB645 ; copy the data to the allocated space
2903 bra LB69D ; return temp string on string stack
2904 ; RIGHT$ function
2905 RIGHT bsr LB6F5 ; get arguments from stack
2906 suba ,x ; subtract length of original string from desired length
2907 nega ; now A is offset into old string where we start copying
2908 bra LB6AE ; go handle everything else
2909 ; MID$ function
2910 MID ldb #255 ; default length is the whole string
2911 stb FPA0+3 ; save it
2912 jsr GETCCH ; see what we have after offset
2913 cmpa #') ; end of function?
2914 beq LB6DE ; brif so - no length
2915 jsr LB26D ; force a comma
2916 bsr LB70B ; get length parameter
2917 LB6DE bsr LB6F5 ; get string and offset parameters from the stack
2918 beq LB706 ; brif we have a 0 offset requested (string offsets are 1-based)
2919 clrb ; clear length counter
2920 deca ; subtract one from position parameter (we work on 0-based, param is 1-based)
2921 cmpa ,x ; is start greater than length of string?
2922 bhs LB6B5 ; brif so - return NULL string
2923 tfr a,b ; save absolute position parameter
2924 subb ,x ; now B is postition less length
2925 negb ; now B is amount of string to copy
2926 cmpb FPA0+3 ; is it less than the length requested?
2927 bls LB6B5 ; brif so
2928 ldb FPA0+3 ; set length to the requested length
2929 bra LB6B5 ; go finish up copying the substring
2930 ; Common routine for LEFT$, RIGHT$, MID$ - check for ) and fetch string data and first parameter
2931 ; from the stack. These were evaluated in the function evaluation handler. (It's not clear that doing
2932 ; it that way is actually beneficial. However, this is what the ROM designers did, so here we are.)
2933 LB6F5 jsr LB267 ; make sure we have )
2934 ldu ,s ; get return address - we're going to mess with the stack
2935 ldx 5,s ; get address of string descriptor
2936 stx V4D ; save descriptor adddress
2937 lda 4,s ; get first numeric parameter in both A and B
2938 ldb 4,s
2939 leas 7,s ; clean up stack
2940 tfr u,pc ; return to original caller
2941 LB706 jmp LB44A ; raise FC error
2942 ; Evaluate an unsigned 8 bit expression to B
2943 LB709 jsr GETNCH ; move to next character
2944 LB70B jsr LB141 ; evaluate a numeric expression
2945 LB70E jsr LB3E9 ; convert to integer in D
2946 tsta ; are we negative or > 255?
2947 bne LB706 ; brif so - FC error
2948 jmp GETCCH ; fetch current input character and return
2949 ; VAL function
2950 VAL jsr LB686 ; get string details
2951 lbeq LBA39 ; brif NULL string - return 0
2952 ldu CHARAD ; get input pointer so we can replace it later
2953 stx CHARAD ; point interpreter at string data
2954 abx ; calculate end address of the string
2955 lda ,x ; get byte after the end of the string
2956 pshs u,x,a ; save end of string address, input pointer, and character after end of string
2957 clr ,x ; put a NUL after the string (stops the number interpreter)
2958 jsr GETCCH ; get input character at start of string
2959 jsr LBD12 ; evaluate numeric expression in string
2960 puls a,x,u ; get back saved character and pointers
2961 sta ,x ; restore byte after string
2962 stu CHARAD ; restore interpeter's input pointer
2963 rts
2964 ; Evaluate unsigned expression to BINVAL, then evaluate an unsigned expression to B
2965 LB734 bsr LB73D ; evaluate expression
2966 stx BINVAL ; save result
2967 LB738 jsr LB26D ; make sure there's a comma
2968 bra LB70B ; evaluate unsigned expression to B
2969 ; Evaluate unsigned expression in X
2970 LB73D jsr LB141 ; evaluate numeric expression
2971 LB740 lda FP0SGN ; is it negative?
2972 bmi LB706 ; brif so
2973 lda FP0EXP ; get exponent
2974 cmpa #0x90 ; largest possible exponent for 16 bits
2975 bhi LB706 ; brif too large
2976 jsr LBCC8 ; move binary point to right of FPA0
2977 ldx FPA0+2 ; get resulting unsigned value
2978 rts
2979 ; PEEK function
2980 PEEK bsr LB740 ; get address to X
2981 ldb ,x ; get the value at that address
2982 jmp LB4F3 ; return B as unsigned value
2983 ; POKE function
2984 POKE bsr LB734 ; evaluate address and byte value
2985 ldx BINVAL ; get address
2986 stb ,x ; put value there
2987 rts
2988 ; LLIST command
2989 LLIST ldb #-2 ; set output device to printer
2990 stb DEVNUM
2991 jsr GETCCH ; reset flags for input character and fall through to LIST
2992 ; LIST command
2993 LIST pshs cc ; save zero flag (end of statement)
2994 jsr LAF67 ; parse line number
2995 jsr LAD01 ; find address of that line
2996 stx LSTTXT ; save that address as the start of the list
2997 puls cc ; get back ent of statement flag
2998 beq LB784 ; brif end of line - list whole program
2999 jsr GETCCH ; are we at the end of the line (one number)?
3000 beq LB789 ; brif end of line
3001 cmpa #0xac ; is it "-"?
3002 bne LB783 ; brif not
3003 jsr GETNCH ; eat the "-"
3004 beq LB784 ; brif no second number - list to end of program
3005 jsr LAF67 ; evaluate the second number
3006 beq LB789 ; brif illegal number
3007 LB783 rts
3008 LB784 ldu #0xffff ; this will cause listing to do the entire program
3009 stu BINVAL
3010 LB789 leas 2,s ; don't return to the caller - we'll jump back to the main loop
3011 ldx LSTTXT ; get address of line to list
3012 LB78D jsr LB95C ; do a newline if needed
3013 jsr LA549 ; do a break check
3014 ldd ,x ; get address of next line
3015 bne LB79F ; brif not end of program
3016 LB797 jsr LA42D ; close output file
3017 clr DEVNUM ; reset device to screen
3018 jmp LAC73 ; go back to immediate mode
3019 LB79F stx LSTTXT ; save new line address
3020 ldd 2,x ; get line number of this line
3021 cmpd BINVAL ; is it above the end line?
3022 bhi LB797 ; brif so - return
3023 jsr LBDCC ; display line number
3024 jsr LB9AC ; put a space after it
3025 ldx LSTTXT ; get line address
3026 bsr LB7C2 ; detokenize the line
3027 ldx [LSTTXT] ; get pointer to next line
3028 ldu #LINBUF+1 ; point to start of detokenized line
3029 LB7B9 lda ,u+ ; get byte from detokenized line
3030 beq LB78D ; brif end of line
3031 jsr LB9B1 ; output character
3032 bra LB7B9 ; handle next character
3033 ; Detokenize a line from (X) to the line input buffer
3034 LB7C2 jsr RVEC24 ; do the RAM hook dance
3035 leax 4,x ; move past next line pointer and line number
3036 ldy #LINBUF+1 ; point to line input buffer (destination)
3037 LB7CB lda ,x+ ; get character from tokenized line
3038 beq LB820 ; brif end of input
3039 bmi LB7E6 ; brif it's a token
3040 cmpa #': ; colon?
3041 bne LB7E2 ; brif not
3042 ldb ,x ; get what's after the colon
3043 cmpb #0x84 ; ELSE?
3044 beq LB7CB ; brif so - suppress the colon
3045 cmpb #0x83 ; '?
3046 beq LB7CB ; brif so - suppress the colon
3047 skip2
3048 LB7E0 lda #'! ; placeholder for unknown token
3049 LB7E2 bsr LB814 ; stow output character
3050 bra LB7CB ; go process another input character
3051 LB7E6 ldu #COMVEC-10 ; point to command interptation table
3052 cmpa #0xff ; is it a function?
3053 bne LB7F1 ; brif not
3054 lda ,x+ ; get function token
3055 leau 5,u ; shift to the function half of the interpretation tables
3056 LB7F1 anda #0x7f ; remove token bias
3057 LB7F3 leau 10,u ; move to next command/function table
3058 tst ,u ; is this table active?
3059 beq LB7E0 ; brif not - use place holder
3060 suba ,u ; subtract number of tokens handled by this table entry
3061 bpl LB7F3 ; brif this token isn't handled here
3062 adda ,u ; undo extra subtraction
3063 ldu 1,u ; get reserved word list for this table
3064 LB801 deca ; are we at the right entry?
3065 bmi LB80A ; brif so
3066 LB804 tst ,u+ ; end of entry?
3067 bpl LB804 ; brif not
3068 bra LB801 ; see if we're there yet
3069 LB80A lda ,u ; get character from wordlist
3070 bsr LB814 ; put character in the buffer
3071 tst ,u+ ; end of word?
3072 bpl LB80A ; brif not
3073 bra LB7CB ; go handle another input character
3074 LB814 cmpy #LINBUF+LBUFMX ; is there room?
3075 bhs LB820 ; brif not
3076 anda #0x7f ; lose bit 7
3077 sta ,y+ ; save character in output
3078 clr ,y ; make sure there's always a NUL terminator
3079 LB820 rts
3080 ; Tokenize the line that the input pointer is pointing to; put result in the line input buffer; return
3081 ; length in D
3082 LB821 jsr RVEC23 ; do the RAM hook dance
3083 ldx CHARAD ; get input pointer
3084 ldu #LINBUF ; set destination pointer
3085 LB829 clr V43 ; clear alpha string flag
3086 clr V44 ; clear DATA flag
3087 LB82D lda ,x+ ; get input character
3088 beq LB852 ; brif end of input
3089 tst V43 ; are we handling an alphanumeric string?
3090 beq LB844 ; brif not
3091 jsr LB3A2 ; set carry if not alpha
3092 bcc LB852 ; brif alpha
3093 cmpa #'0 ; is it below the digits?
3094 blo LB842 ; brif so
3095 cmpa #'9 ; is it within the digits?
3096 bls LB852 ; brif so
3097 LB842 clr V43 ; flag that we're past the alphanumeric string
3098 LB844 cmpa #0x20 ; space?
3099 beq LB852 ; brif so - keep it
3100 sta V42 ; save scan delimiter
3101 cmpa #'" ; string delimiter?
3102 beq LB886 ; brif so - copy until another "
3103 tst V44 ; doing "DATA"?
3104 beq LB86B ; brif not
3105 LB852 sta ,u+ ; put character in output
3106 beq LB85C ; brif end of input
3107 cmpa #': ; colon?
3108 beq LB829 ; brif so - reset DATA and alpha string flags
3109 LB85A bra LB82D ; go process another input character
3110 LB85C clr ,u+ ; put a double NUL at the end
3111 clr ,u+
3112 tfr u,d ; calculate length of result (includes double NUL and an extra two bytes)
3113 subd #LINHDR
3114 ldx #LINBUF-1 ; point to one before the output
3115 stx CHARAD ; set input pointer there
3116 rts
3117 LB86B cmpa #'? ; print abbreviation?
3118 bne LB873 ; brif not
3119 lda #0x87 ; token for PRINT
3120 bra LB852 ; go stash it
3121 LB873 cmpa #'' ; REM abbreviation?
3122 bne LB88A ; brif not
3123 ldd #0x3a83 ; colon plus ' token
3124 std ,u++ ; put it in the output
3125 LB87C clr V42 ; set delimiter to NUL
3126 LB87E lda ,x+ ; get input
3127 beq LB852 ; brif end of line
3128 cmpa V42 ; at the delimiter?
3129 beq LB852 ; brif so
3130 LB886 sta ,u+ ; save in output
3131 bra LB87E ; keep scanning for delimiter
3132 LB88A cmpa #'0 ; is it below digits?
3133 blo LB892 ; brif so
3134 cmpa #';+1 ; is it digit, colon, or semicolon?
3135 blo LB852 ; brif so
3136 LB892 leax -1,x ; move input pointer back one (to point at this input character)
3137 pshs u,x ; save input and output pointers
3138 clr V41 ; set token type to 0 (command)
3139 ldu #COMVEC-10 ; point to command interpretation table
3140 LB89B clr V42 ; set token counter to 0 (0x80)
3141 LB89D leau 10,u ;
3142 lda ,u ; get number of reserved words
3143 beq LB8D4 ; brif this table isn't active
3144 ldy 1,u ; point to reserved words list
3145 LB8A6 ldx ,s ; get input pointer
3146 LB8A8 ldb ,y+ ; get character from reserved word table
3147 subb ,x+ ; compare with input character
3148 beq LB8A8 ; brif exact match
3149 cmpb #0x80 ; brif it was the last character in word and exact match
3150 bne LB8EA ; brif not
3151 leas 2,s ; remove original input pointer from stack
3152 puls u ; get back output pointer
3153 orb V42 ; create token value (B has 0x80 from above)
3154 lda V41 ; get token type
3155 bne LB8C2 ; brif function
3156 cmpb #0x84 ; is it ELSE?
3157 bne LB8C6 ; brif not
3158 lda #': ; silently add a colon before ELSE
3159 LB8C2 std ,u++ ; put two byte token into output
3160 bra LB85A ; go handle more input
3161 LB8C6 stb ,u+ ; save single byte token
3162 cmpb #0x86 ; DATA?
3163 bne LB8CE ; brif not
3164 inc V44 ; set DATA flag
3165 LB8CE cmpb #0x82 ; REM?
3166 beq LB87C ; brif so - skip over rest of line
3167 LB8D2 bra LB85A ; go handle more input
3168 LB8D4 ldu #COMVEC-5 ; point to interpretation table, function style
3169 LB8D7 com V41 ; invert token flag
3170 bne LB89B ; brif we haven't already done functions
3171 puls x,u ; restore input and output pointers
3172 lda ,x+ ; copy first character
3173 sta ,u+
3174 jsr LB3A2 ; set C if not alpha
3175 bcs LB8D2 ; brif not alpha - it isn't a variable
3176 com V43 ; set alphanumeric string flag
3177 bra LB8D2 ; process more input
3178 LB8EA inc V42 ; bump token number
3179 deca ; checked all in this table?
3180 beq LB89D ; brif so
3181 leay -1,y ; unconsume last compared character
3182 LB8F1 ldb ,y+ ; end of entry?
3183 bpl LB8F1 ; brif not
3184 bra LB8A6 ; check next reserved word
3185 ; PRINT command
3186 PRINT beq LB958 ; brif no argument - do a newline
3187 bsr LB8FE ; process print options
3188 clr DEVNUM ; reset output to screen
3189 rts
3190 LB8FE cmpa #'@ ; is it PRINT @?
3191 bne LB907 ; brif not
3192 jsr LA554 ; move cursor to correct location
3193 bra LB911 ; handle some more
3194 LB907 cmpa #'# ; device number specified?
3195 bne LB918 ; brif not
3196 jsr LA5A5 ; parse device number
3197 jsr LA406 ; check for valid output file
3198 LB911 jsr GETCCH ; get input character
3199 beq LB958 ; brif nothing - do newline
3200 jsr LB26D ; need comma after @ or #
3201 LB918 jsr RVEC9 ; do the RAM hook boogaloo
3202 LB91B beq LB965 ; brif end of input
3203 LB91D cmpa #0xa4 ; TAB(?
3204 beq LB97E ; brif so
3205 cmpa #', ; comma (next tab field)?
3206 beq LB966 ; brif so
3207 cmpa #'; ; semicolon (do not advance print position)
3208 beq LB997 ; brif so
3209 jsr LB156 ; evaluate expression
3210 lda VALTYP ; get type of value
3211 pshs a ; save it
3212 bne LB938 ; brif string
3213 jsr LBDD9 ; convert FP number to string
3214 jsr LB516 ; parse a string and put on string stack
3215 LB938 bsr LB99F ; print string
3216 puls b ; get back variable type
3217 jsr LA35F ; set up print parameters
3218 tst PRTDEV ; is it a display device?
3219 beq LB949 ; brif so
3220 bsr LB958 ; do a newline
3221 jsr GETCCH ; get input
3222 bra LB91B ; process more print stuff
3223 LB949 tstb ; set flags on print position
3224 bne LB954 ; brif not at start of line
3225 jsr GETCCH ; get current input
3226 cmpa #', ; comma?
3227 beq LB966 ; skip to next tab field if so
3228 bsr LB9AC ; send a space
3229 LB954 jsr GETCCH ; get input character
3230 bne LB91D ; brif not end of statement
3231 LB958 lda #0x0d ; carriage return
3232 bra LB9B1 ; send it to output
3233 LB95C jsr LA35F ; set up print parameters
3234 LB95F beq LB958 ; brif width is 0
3235 lda DEVPOS ; get line position
3236 bne LB958 ; brif not at start of line
3237 LB965 rts
3238 LB966 jsr LA35F ; set up print parameters
3239 beq LB975 ; brif line width is 0
3240 ldb DEVPOS ; get line position
3241 cmpb DEVLCF ; at or past last comma field?
3242 blo LB977 ; brif so
3243 bsr LB958 ; move to next line
3244 bra LB997 ; handle more stuff
3245 LB975 ldb DEVPOS ; get line position
3246 LB977 subb DEVCFW ; subtract a comma field width
3247 bhs LB977 ; brif we don't have a remainder yet
3248 negb ; now B is number of of spaces needed
3249 bra LB98E ; go advance
3250 LB97E jsr LB709 ; evaluate TAB distance
3251 cmpa #') ; closing )?
3252 lbne LB277 ; brif not
3253 jsr LA35F ; set up print parameters
3254 subb DEVPOS ; subtract print position from desired position
3255 bls LB997 ; brif we're already past it
3256 LB98E tst PRTDEV ; is it a display device?
3257 bne LB997 ; brif not
3258 LB992 bsr LB9AC ; output a space
3259 decb ; done enough?
3260 bne LB992 ; brif not
3261 LB997 jsr GETNCH ; get input character
3262 jmp LB91B ; process more items
3263 ; cpoy string from (X-1) to output
3264 LB99C jsr LB518 ; parse the string
3265 LB99F jsr LB657 ; get string details
3266 LB9A2 incb ; compensate for decb
3267 LB9A3 decb ; done all of the string?
3268 beq LB965 ; brif so
3269 lda ,x+ ; get character from string
3270 bsr LB9B1 ; send to output
3271 bra LB9A3 ; go do another character
3272 LB9AC lda #0x20 ; space character
3273 skip2
3274 LB9AF lda #'? ; question mark character
3275 LB9B1 jmp PUTCHR ; output character
3276 ; The floating point math package and related functions and operations follow from here
3277 ; to the end of the Color Basic ROM area
3278 LB9B4 ldx #LBEC0 ; point to FP constant 0.5
3279 bra LB9C2 ; add 0.5 to FPA0
3280 LB9B9 jsr LBB2F ; unpack FP data from (X) to FPA1
3281 ; subtraction operator
3282 LB9BC com FP0SGN ; invert sign of FPA0 (subtracting is adding the negative)
3283 com RESSGN ; that also inverts the sign differential
3284 bra LB9C5 ; go add the negative of FPA0 to FPA1
3285 LB9C2 jsr LBB2F ; unpack FP data from (X) to FPA1
3286 ; addition operator
3287 LB9C5 tstb ; check exponent of FPA0
3288 lbeq LBC4A ; copy FPA1 to FPA0 if FPA0 is 0
3289 ldx #FP1EXP ; point X to FPA1 (first operand) as the operand to denormalize
3290 LB9CD tfr a,b ; put exponent of FPA1 into B
3291 tstb ; is FPA1 0?
3292 beq LBA3E ; brif exponent is 0 - no-op; adding 0 to FPA0
3293 subb FP0EXP ; get difference in exponents - number of bits to shift the smaller mantissa
3294 beq LBA3F ; brif exponents are equal - no need to denormalize
3295 bmi LB9E2 ; brif FPA0 > FPA1
3296 sta FP0EXP ; replace result exponent with FPA1's (FPA1 is bigger)
3297 lda FP1SGN ; also copy sign over
3298 sta FP0SGN
3299 ldx #FP0EXP ; point to FPA0 (we need to denormalize the smaller number)
3300 negb ; invert the difference - this is the number of bits to shift the mantissa
3301 LB9E2 cmpb #-8 ; do we have to shift by a whole byte?
3302 ble LBA3F ; brif so start by shifting whole bytes to the right
3303 clra ; clear overflow byte
3304 lsr 1,x ; shift high bit of mantissa right (LSR will force a zero into the high bit)
3305 jsr LBABA ; shift remainder of mantissa right -B times
3306 LB9EC ldb RESSGN ; get the sign flag
3307 bpl LB9FB ; brif signs are the same (we add the mantissas then)
3308 com 1,x ; complement the mantissa and extra precision bytes
3309 com 2,x
3310 com 3,x
3311 com 4,x
3312 coma
3313 adca #0 ; add one to A (COM sets C); this may cause a carry to enter the ADD below
3314 LB9FB sta FPSBYT ; save extra precision byte
3315 lda FPA0+3 ; add the main mantissa bytes (and propage carry from above)
3316 adca FPA1+3
3317 sta FPA0+3
3318 lda FPA0+2
3319 adca FPA1+2
3320 sta FPA0+2
3321 lda FPA0+1
3322 adca FPA1+1
3323 sta FPA0+1
3324 lda FPA0
3325 adca FPA1
3326 sta FPA0
3327 tstb ; were signs the same?
3328 bpl LBA5C ; brif so - number may have gotten bigger so normalize if needed
3329 LBA18 bcs LBA1C ; brif we had a carry - result is positive?)
3330 bsr LBA79 ; do a proper negation of FPA0 mantissa
3331 LBA1C clrb ; clear temporary exponent accumulator
3332 LBA1D lda FPA0 ; test high byte of mantissa
3333 bne LBA4F ; brif not 0 - we need to do bit shifting
3334 lda FPA0+1 ; shift left 8 bits
3335 sta FPA0
3336 lda FPA0+2
3337 sta FPA0+1
3338 lda FPA0+3
3339 sta FPA0+2
3340 lda FPSBYT
3341 sta FPA0+3
3342 clr FPSBYT
3343 addb #8 ; account for 8 bits shifted
3344 cmpb #5*8 ; shifted 5 bytes worth?
3345 blt LBA1D ; brif not
3346 LBA39 clra ; zero out exponent and sign - result is 0
3347 LBA3A sta FP0EXP ; set exponent and sign
3348 sta FP0SGN
3349 LBA3E rts
3350 LBA3F bsr LBAAE ; shift FPA0 mantissa to the right
3351 clrb ; clear carry
3352 bra LB9EC ; get on with adding
3353 LBA44 incb ; account for one bit shift
3354 asl FPSBYT ; shift mantissa and extra precision left
3355 rol FPA0+3
3356 rol FPA0+2
3357 rol FPA0+1
3358 rol FPA0
3359 LBA4F bpl LBA44 ; brif we haven't got a 1 in bit 7
3360 lda FP0EXP ; get exponent of result
3361 pshs b ; subtract shift count from exponent
3362 suba ,s+
3363 sta FP0EXP ; save adjusted exponent
3364 bls LBA39 ; brif we underflowed - set result to 0
3365 skip2
3366 LBA5C bcs LBA66 ; brif mantissa overflowed
3367 asl FPSBYT ; get bit 7 of expra precision to C (used for round off)
3368 lda #0 ; set to 0 without affecting C
3369 sta FPSBYT ; clear out extra precision bits
3370 bra LBA72 ; go round off result
3371 LBA66 inc FP0EXP ; bump exponent (for a right shift to bring carry in)
3372 beq LBA92 ; brif we overflowed
3373 ror FPA0 ; shift carry into mantissa, shift right
3374 ror FPA0+1
3375 ror FPA0+2
3376 ror FPA0+3
3377 LBA72 bcc LBA78 ; brif no round-off needed
3378 bsr LBA83 ; add one to mantissa
3379 beq LBA66 ; brif carry - need to shift right again
3380 LBA78 rts
3381 LBA79 com FP0SGN ; invert sign of value
3382 LBA7B com FPA0 ; first do a one's copmlement
3383 com FPA0+1
3384 com FPA0+2
3385 com FPA0+3
3386 LBA83 ldx FPA0+2 ; add one to mantissa (after one's complement gives two's complement)
3387 leax 1,x ; bump low word
3388 stx FPA0+2
3389 bne LBA91 ; brif no carry from low word
3390 ldx FPA0 ; bump high word
3391 leax 1,x
3392 stx FPA0
3393 LBA91 rts
3394 LBA92 ldb #2*5 ; code for overflow
3395 jmp LAC46 ; raise error
3396 LBA97 ldx #FPA2-1 ; point to FPA2
3397 LBA9A lda 4,x ; shift mantissa right by 8 bits
3398 sta FPSBYT
3399 lda 3,x
3400 sta 4,x
3401 lda 2,x
3402 sta 3,x
3403 lda 1,x
3404 sta 2,x
3405 lda FPCARY ; and handle extra precision on the left
3406 sta 1,x
3407 LBAAE addb #8 ; account for 8 bits shifted
3408 ble LBA9A ; brif more shifts needed
3409 lda FPSBYT ; get sub byte (extra precision)
3410 subb #8 ; undo the 8 added above
3411 beq LBAC4 ; brif difference is 0
3412 LBAB8 asr 1,x ; shift mantissa and sub byte one bit (keep mantissa high bit set)
3413 LBABA ror 2,x
3414 ror 3,x
3415 ror 4,x
3416 rora
3417 incb ; account for one shift
3418 bne LBAB8 ; brif not enought shifts yet
3419 LBAC4 rts
3420 LBAC5 fcb 0x81,0x00,0x00,0x00,0x00 ; packed FP 1.0
3421 LBACA bsr LBB2F ; unpack FP value from (X) to FPA1
3422 ; multiplication operator
3423 LBACC beq LBB2E ; brif exponent of FPA0 is 0 (result is 0)
3424 bsr LBB48 ; calculate exponent of product
3425 LBAD0 lda #0 ; zero out mantissa of FPA2
3426 sta FPA2
3427 sta FPA2+1
3428 sta FPA2+2
3429 sta FPA2+3
3430 ldb FPA0+3 ; multiply FPA1 by LSB of FPA0
3431 bsr LBB00
3432 ldb FPSBYT ; save extra precision byte
3433 stb VAE
3434 ldb FPA0+2
3435 bsr LBB00 ; again for next byte of FPA0
3436 ldb FPSBYT
3437 stb VAD
3438 ldb FPA0+1 ; again for next byte of FPA0
3439 bsr LBB00
3440 ldb FPSBYT
3441 stb VAC
3442 ldb FPA0 ; and finally for the high byte
3443 bsr LBB02
3444 ldb FPSBYT
3445 stb VAB
3446 jsr LBC0B ; copy mantissa from FPA2 to FPA0 (result)
3447 jmp LBA1C ; normalize
3448 LBB00 beq LBA97 ; brif multiplier is 0 - just shift, don't multiply
3449 LBB02 coma ; set carry
3450 LBB03 lda FPA2 ; get FPA2 MS byte
3451 rorb ; data bit to carry; will be 0 when all shifts done
3452 beq LBB2E ; brif 8 shifts done
3453 bcc LBB20 ; brif data bit is 0 - no addition
3454 lda FPA2+3 ; add mantissa of FPA1 and FPA2
3455 adda FPA1+3
3456 sta FPA2+3
3457 lda FPA2+2
3458 adca FPA1+2
3459 sta FPA2+2
3460 lda FPA2+1
3461 adca FPA1+1
3462 sta FPA2+1
3463 lda FPA2
3464 adca FPA1
3465 LBB20 rora ; shift carry into FPA2
3466 sta FPA2
3467 ror FPA2+1
3468 ror FPA2+2
3469 ror FPA2+3
3470 ror FPSBYT
3471 clra ; clear carry
3472 bra LBB03
3473 LBB2E rts
3474 ; Unpack FP value from (X) to FPA1
3475 LBB2F ldd 1,x ; copy mantissa (and sign)
3476 sta FP1SGN ; save sign bit
3477 ora #0x80 ; make sure mantissa has bit 7 set
3478 std FPA1
3479 ldb FP1SGN ; get sign
3480 eorb FP0SGN ; set if FPA0 sign differs
3481 stb RESSGN
3482 ldd 3,x ; copy remainder of mantissa
3483 std FPA1+2
3484 lda ,x ; and exponent
3485 sta FP1EXP
3486 ldb FP0EXP ; fetch FPA0 exponent and set flags
3487 rts
3488 ; Calculate eponent for product of FPA0 and FPA1
3489 LBB48 tsta ; is FPA1 zero?
3490 beq LBB61 ; brif so
3491 adda FP0EXP ; add to exponent of FPA0 (this is how scientific notation works)
3492 rora ; set V if we *don't* have an overflow
3493 rola
3494 bvc LBB61 ; brif exponent too larger or small
3495 adda #0x80 ; restore the bias
3496 sta FP0EXP ; set result exponent
3497 beq LBB63 ; brif 0 - clear FPA0
3498 lda RESSGN ; the result sign (negative if signs differ) is the result sign
3499 sta FP0SGN ; so set it as such
3500 rts
3501 LBB5C lda FP0SGN ; get sign of FPA0
3502 coma ; invert sign
3503 bra LBB63 ; zero sign and exponent
3504 LBB61 leas 2,s ; don't go back to caller (mul/div) - return to previous caller
3505 LBB63 lbpl LBA39 ; brif we underflowed - go zero things out
3506 LBB67 jmp LBA92 ; raise overflow error
3507 ; fast multiply by 10 - leave result in FPA0
3508 LBB6A jsr LBC5F ; copy FPA0 to FPA1 (for addition later)
3509 beq LBB7C ; brif exponent is 0 - it's a no-op then
3510 adda #2 ; this gives "times 4"
3511 bcs LBB67 ; raise overflow if required
3512 clr RESSGN ; set result sign to "signs the same"
3513 jsr LB9CD ; add FPA1 to FPA0 "times 5"
3514 inc FP0EXP ; times 10
3515 beq LBB67 ; brif overflow
3516 LBB7C rts
3517 LBB7D fcb 0x84,0x20,0x00,0x00,0x00 ; packed FP constant 10.0
3518 ; Divide by 10
3519 LBB82 jsr LBC5F ; move FPA0 to FPA1
3520 ldx #LBB7D ; point to constant 10
3521 clrb ; zero sign
3522 LBB89 stb RESSGN ; result will be positive or zero
3523 jsr LBC14 ; unpack constant 10 to FPA0
3524 skip2 ; fall through to division (divide FPA1 by 10)
3525 LBB8F bsr LBB2F ; unpack FP number from (X) to FPA1
3526 ; division operator
3527 LBB91 beq LBC06 ; brif FPA0 is 0 - division by zero
3528 neg FP0EXP ; get exponent of reciprocal of the divisor
3529 bsr LBB48 ; calculate exponent of quotient
3530 inc FP0EXP ; bump exponent (due to division algorithm below)
3531 beq LBB67 ; brif overflow
3532 ldx #FPA2 ; point to temporary storage location
3533 ldb #4 ; do 5 bytes
3534 stb TMPLOC ; save counter
3535 ldb #1 ; shift counter and quotient byte
3536 LBBA4 lda FPA0 ; compare mantissa of FPA0 to FPA1, set C if FPA1 less
3537 cmpa FPA1
3538 bne LBBBD
3539 lda FPA0+1
3540 cmpa FPA1+1
3541 bne LBBBD
3542 lda FPA0+2
3543 cmpa FPA1+2
3544 bne LBBBD
3545 lda FPA0+3
3546 cmpa FPA1+3
3547 bne LBBBD
3548 coma ; set C if FPA0 = FPA1 (it "goes")
3549 LBBBD tfr cc,a ; save "it goes" status
3550 rolb ; rotate carry into quotient
3551 bcc LBBCC ; brif carry clear - haven't done 8 shifts yet
3552 stb ,x+ ; save quotient byte
3553 dec TMPLOC ; done enough bytes?
3554 bmi LBBFC ; brif done all 5
3555 beq LBBF8 ; brif last byte
3556 ldb #1 ; reset shift counter and quotient byte
3557 LBBCC tfr a,cc ; get back carry status
3558 bcs LBBDE ; brif it "went"
3559 LBBD0 asl FPA1+3 ; shift mantissa (dividend) left
3560 rol FPA1+2
3561 rol FPA1+1
3562 rol FPA1
3563 bcs LBBBD ; brif carry - it "goes" so we have to bump quotient
3564 bmi LBBA4 ; brif high order bit is set - compare mantissas
3565 bra LBBBD ; otherwise, count a 0 bit and try next bit
3566 LBBDE lda FPA1+3 ; subtract mantissa of FPA0 from mantissa of FPA1
3567 suba FPA0+3
3568 sta FPA1+3
3569 lda FPA1+2
3570 sbca FPA0+2
3571 sta FPA1+2
3572 lda FPA1+1
3573 sbca FPA0+1
3574 sta FPA1+1
3575 lda FPA1
3576 sbca FPA0
3577 sta FPA1
3578 bra LBBD0 ; go check for another go
3579 LBBF8 ldb #0x40 ; only two bits in last byte (for rounding)
3580 bra LBBCC ; go do the last byte
3581 LBBFC rorb ; get low bits to bits 7,6 and C to bit 5
3582 rorb
3583 rorb
3584 stb FPSBYT ; save result extra precision
3585 bsr LBC0B ; move FPA2 mantissa to FPA0 (result)
3586 jmp LBA1C ; go normalize the result
3587 LBC06 ldb #2*10 ; division by zero
3588 jmp LAC46 ; raise error
3589 ; Copy mantissa of FPA2 to FPA0
3590 LBC0B ldx FPA2 ; copy high word
3591 stx FPA0
3592 ldx FPA2+2 ; copy low word
3593 stx FPA0+2
3594 rts
3595 ; unpack FP number at (X) to FPA0
3596 LBC14 pshs a ; save register
3597 ldd 1,x ; get mantissa high word and sign
3598 sta FP0SGN ; set sign
3599 ora #0x80 ; make sure mantissa always has bit 7 set
3600 std FPA0
3601 clr FPSBYT ; clear extra precision
3602 ldb ,x ; get exponent
3603 ldx 3,x ; copy mantissa low word
3604 stx FPA0+2
3605 stb FP0EXP ; save exponent (and set flags)
3606 puls a,pc ; restore register and return
3607 LBC2A ldx #V45 ; point to FPA4
3608 bra LBC35 ; pack FPA0 there
3609 LBC2F ldx #V40 ; point to FPA3
3610 skip2 ; fall through to pack FPA0 there
3611 LBC33 ldx VARDES ; get variable descriptor pointer
3612 ; Pack FPA0 to (X)
3613 LBC35 lda FP0EXP ; get exponent
3614 sta ,x ; save it
3615 lda FP0SGN ; get sign
3616 ora #0x7f ; force set low bits - only keep sign in high bit
3617 anda FPA0 ; merge in bits 6-0 of high byte of mantissa
3618 sta 1,x ; save it
3619 lda FPA0+1 ; copy next highest byte
3620 sta 2,x
3621 ldu FPA0+2 ; and the low word of the mantissa
3622 stu 3,x
3623 rts
3624 ; Copy FPA1 to FPA0; return with sign in A
3625 LBC4A lda FP1SGN ; copy sign
3626 LBC4C sta FP0SGN
3627 ldx FP1EXP ; copy exponent, mantissa high byte
3628 stx FP0EXP
3629 clr FPSBYT ; clear extra precision
3630 lda FPA1+1 ; copy mantissa second highest byte
3631 sta FPA0+1
3632 lda FP0SGN ; set sign for return
3633 ldx FPA1+2 ; copy low word of mantissa
3634 stx FPA0+2
3635 rts
3636 ; Copy FPA0 to FPA1
3637 LBC5F ldd FP0EXP ; copy exponent and high byte of mantissa
3638 std FP1EXP
3639 ldx FPA0+1 ; copy middle bytes of mantissa
3640 stx FPA1+1
3641 ldx FPA0+3 ; copy low byte of mantissa and sign
3642 stx FPA1+3
3643 tsta ; set flags on exponent
3644 rts
3645 ; check FPA0: return B = 0, if FPA0 is 0, 0xff if negative, and 0x01 if positive
3646 LBC6D ldb FP0EXP ; get exponent
3647 beq LBC79 ; brif 0
3648 LBC71 ldb FP0SGN ; get sign
3649 LBC73 rolb ; get sign to C
3650 ldb #0xff ; set for negative result
3651 bcs LBC79 ; brif negative
3652 negb ; set to 1 for positive
3653 LBC79 rts
3654 ; SGN function
3655 SGN bsr LBC6D ; get sign of FPA0
3656 LBC7C stb FPA0 ; save result
3657 clr FPA0+1 ; clear next lower 8 bits
3658 ldb #0x88 ; exponent if mantissa is 8 bit integer
3659 LBC82 lda FPA0 ; get high bits of mantissa
3660 suba #0x80 ; set C if mantissa was positive (will cause a negation if it was negative)
3661 LBC86 stb FP0EXP ; set exponent
3662 ldd ZERO ; clear out low word
3663 std FPA0+2
3664 sta FPSBYT ; clear extra precision
3665 sta FP0SGN ; set sign to positive
3666 jmp LBA18 ; normalize the result
3667 ; ABS function
3668 ABS clr FP0SGN ; force FPA0 to be positive (yes, it's that simple)
3669 rts
3670 ; Compare packed FP number at (X) to FPA0
3671 ; Return with B = -1, 0, 1 for FPA0 <, =, > (X) and flags set based on that
3672 LBC96 ldb ,x ; get exponent of (X)
3673 beq LBC6D ; brif (X) is 0
3674 ldb 1,x ; get MS byte of mantissa of (X)
3675 eorb FP0SGN ; set bit 7 if signs of (X) and FPA0 differ
3676 bmi LBC71 ; brif signs differ - no need to compare the magnitude
3677 LBCA0 ldb FP0EXP ; compare exponents and brif different
3678 cmpb ,x
3679 bne LBCC3
3680 ldb 1,x ; compare mantissa (but we have to pack the FPA0 bits first
3681 orb #0x7f ; keep only sign bit (note: signs are the same)
3682 andb FPA0 ; merge in the mantissa bits from FPA0
3683 cmpb 1,x ; do the packed versions match?
3684 bne LBCC3 ; brif not
3685 ldb FPA0+1 ; compare second byte of mantissas
3686 cmpb 2,x
3687 bne LBCC3
3688 ldb FPA0+2 ; compare third byte of mantissas
3689 cmpb 3,x
3690 bne LBCC3
3691 ldb FPA0+3 ; compare low byte of mantissas, but use subtraction so B = 0 on match
3692 subb 4,x
3693 bne LBCC3
3694 rts ; return B = 0 if (X) = FPA0
3695 LBCC3 rorb ; shift carry to bit 7 (C set if FPA0 < (X))
3696 eorb FP0SGN ; invert the comparision sense if the signs are negative
3697 bra LBC73 ; interpret comparison result
3698 ; Shift mantissa of FPA0 until the binary point is immediately to the right of the mantissa and set up the
3699 ; result as a two's complement value.
3700 LBCC8 ldb FP0EXP ; get exponent of FPA0
3701 beq LBD09 ; brif FPA0 is zero - we don't have to do anything, just blank it
3702 subb #0xa0 ; calculate number of shifts to get to the correct exponent (binary point to the right)
3703 lda FP0SGN ; do we have a positive number?
3704 bpl LBCD7 ; brif so
3705 com FPCARY ; negate the mantissa and set extra inbound precision to the correct sign
3706 jsr LBA7B
3707 LBCD7 ldx #FP0EXP ; point to FPA0
3708 cmpb #-8 ; moving by whole bytes?
3709 bgt LBCE4 ; brif not
3710 jsr LBAAE ; do bit shifting
3711 clr FPCARY ; clear carry in byte
3712 rts
3713 LBCE4 clr FPCARY ; clear the extra carry in precision
3714 lda FP0SGN ; get sign of value
3715 rola ; get sign to carry (so rotate repeats the sign)
3716 ror FPA0 ; shift the first bit
3717 jmp LBABA ; do the shifting dance
3718 ; INT function
3719 INT ldb FP0EXP ; get exponent
3720 cmpb #0xa0 ; is the number big enough that there can be no fractional part?
3721 bhs LBD11 ; brif so - we don't have to do anything
3722 bsr LBCC8 ; go shift binary point to the right of the mantissa
3723 stb FPSBYT ; save extra precision bits
3724 lda FP0SGN ; get original sign
3725 stb FP0SGN ; force result to be positive
3726 suba #0x80 ; set C if we had a positive result
3727 lda #0xa0 ; set exponent to match denormalized result
3728 sta FP0EXP
3729 lda FPA0+3 ; save low byte
3730 sta CHARAC
3731 jmp LBA18 ; go normalize (this will correct for the two's complement representation of negatives)
3732 LBD09 stb FPA0 ; replace mantissa of FPA0 with contents of B
3733 stb FPA0+1
3734 stb FPA0+2
3735 stb FPA0+3
3736 LBD11 rts
3737 ; Convert ASCII string to FP
3738 ; BUG: no overflow is checked on the decimal exponent in exponential notation.
3739 LBD12 ldx ZERO ; zero out FPA0 and temporaries
3740 stx FP0SGN
3741 stx FP0EXP
3742 stx FPA0+1
3743 stx FPA0+2
3744 stx V47
3745 stx V45
3746 bcs LBD86 ; brif input character is numeric
3747 jsr RVEC19 ; do the RAM hook dance
3748 cmpa #'- ; regular negative sign
3749 bne LBD2D ; brif not
3750 com COEFCT ; invert sign
3751 bra LBD31 ; process stuff after the sign
3752 LBD2D cmpa #'+ ; regular plus?
3753 bne LBD35 ; brif not
3754 LBD31 jsr GETNCH ; get character after sign
3755 bcs LBD86 ; brif numeric
3756 LBD35 cmpa #'. ; decimal point?
3757 beq LBD61 ; brif so
3758 cmpa #'E ; scientific notation
3759 bne LBD65 ; brif not
3760 jsr GETNCH ; eat the "E"
3761 bcs LBDA5 ; brif numeric
3762 cmpa #0xac ; negative sign (token)?
3763 beq LBD53 ; brif so
3764 cmpa #'- ; regular negative?
3765 beq LBD53 ; brif so
3766 cmpa #0xab ; plus sign (token)?
3767 beq LBD55 ; brif so
3768 cmpa #'+ ; regular plus?
3769 beq LBD55
3770 bra LBD59 ; brif no sign found
3771 LBD53 com V48 ; set exponent sign to negative
3772 LBD55 jsr GETNCH ; eat the sign
3773 bcs LBDA5 ; brif numeric
3774 LBD59 tst V48 ; is the exponent sign negatvie?
3775 beq LBD65 ; brif not
3776 neg V47 ; negate base 10 exponent
3777 bra LBD65
3778 LBD61 com V46 ; toggle decimal point flag
3779 bne LBD31 ; brif we haven't seen two decimal points
3780 LBD65 lda V47 ; get base 10 exponent
3781 suba V45 ; subtract number of places to the right
3782 sta V47 ; we now have a complete decimal exponent
3783 beq LBD7F ; brif we have no base 10 shifting required
3784 bpl LBD78 ; brif positive exponent
3785 LBD6F jsr LBB82 ; divide FPA0 by 10 (shift decimal point left)
3786 inc V47 ; bump exponent
3787 bne LBD6F ; brif we haven't reached 0 yet
3788 bra LBD7F ; return result
3789 LBD78 jsr LBB6A ; multiply by 10
3790 dec V47 ; downshift the exponent
3791 bne LBD78 ; brif not at 0 yet
3792 LBD7F lda COEFCT ; get desired sign
3793 bpl LBD11 ; brif it will be positive - no need to do anything
3794 jmp LBEE9 ; flip the sign of FPA0
3795 LBD86 ldb V45 ; get the decimal count
3796 subb V46 ; (if decimal seen, will add one; otherwise it does nothing)
3797 stb V45
3798 pshs a ; save new digit
3799 jsr LBB6A ; multiply partial result by 10
3800 puls b ; get back digit
3801 subb #'0 ; remove ASCII bias
3802 bsr LBD99 ; add B to FPA0
3803 bra LBD31 ; go process another digit
3804 LBD99 jsr LBC2F ; save FPA0 to FPA3
3805 jsr LBC7C ; convert B to FP number
3806 ldx #V40 ; point to FPA3
3807 jmp LB9C2 ; add FPA3 and FPA0
3808 LBDA5 ldb V47 ; get exponent value
3809 aslb ; times 2
3810 aslb ; times 4
3811 addb V47 ; times 5
3812 aslb ; times 10
3813 suba #'0 ; remove ASCII bias
3814 pshs b ; save acculated result
3815 adda ,s+ ; add new digit to accumulated result
3816 sta V47 ; save new accumulated decimal exponent
3817 bra LBD55 ; interpret another exponent character
3818 LBDB6 fcb 0x9b,0x3e,0xbc,0x1f,0xfd ; packed FP: 99999999.9
3819 LBDBB fcb 0x9e,0x6e,0x6b,0x27,0xfd ; packed FP: 999999999
3820 LBDC0 fcb 0x9e,0x6e,0x6b,0x28,0x00 ; pakced FP: 1E9
3821 LBDC5 ldx #LABE8-1 ; point to "IN" message
3822 bsr LBDD6 ; output the string
3823 ldd CURLIN ; get basic line number
3824 LBDCC std FPA0 ; save 16 bit unsigned integer
3825 ldb #0x90 ; exponent for upper 16 bits of FPA0 to be an integer
3826 coma ; set C (force normalization to treat as positive)
3827 jsr LBC86 ; zero bottom half, save exponent, and normalize
3828 bsr LBDD9 ; convert FP number to ASCII string
3829 LBDD6 jmp LB99C ; output string
3830 ; Convert FP number to ASCII string
3831 LBDD9 ldu #STRBUF+3 ; point to buffer address that will not cause string to go to string space
3832 LBDDC lda #0x20 ; default sign is a space character
3833 ldb FP0SGN ; get sign of value
3834 bpl LBDE4 ; brif positive
3835 lda #'- ; use negative sign
3836 LBDE4 sta ,u+ ; save sign
3837 stu COEFPT ; save output buffer pointer
3838 sta FP0SGN ; save sign character
3839 lda #'0 ; result is 0 if exponent is 0
3840 ldb FP0EXP ; get exponent
3841 lbeq LBEB8 ; brif FPA0 is 0
3842 clra ; base 10 exponent is 0 for > 1
3843 cmpb #0x80 ; is number > 1?
3844 bhi LBDFF ; brif so
3845 ldx #LBDC0 ; point to 1E+09
3846 jsr LBACA ; shift decimal to the right by 9 spaces
3847 lda #-9 ; account for shift
3848 LBDFF sta V45 ; save base 10 exponent
3849 LBE01 ldx #LBDBB ; point to 999999999
3850 jsr LBCA0 ; are we above that?
3851 bgt LBE18 ; brif so
3852 LBE09 ldx #LBDB6 ; point to 99999999.9
3853 jsr LBCA0 ; are we above that?
3854 bgt LBE1F ; brif in range
3855 jsr LBB6A ; multiply by 10 (we were small)
3856 dec V45 ; account for shift
3857 bra LBE09 ; see if we've come into range
3858 LBE18 jsr LBB82 ; divide by 10
3859 inc V45 ; account for shift
3860 bra LBE01 ; see if we've come into range
3861 LBE1F jsr LB9B4 ; add 0.5 to FPA0 (rounding)
3862 jsr LBCC8 ; do the integer dance
3863 ldb #1 ; default decimal flag (force immediate decimal)
3864 lda V45 ; get base 10 exponent
3865 adda #10 ; account for "unormalized" number
3866 bmi LBE36 ; brif number < 1.0
3867 cmpa #11 ; do we have more than 9 places?
3868 bhs LBE36 ; brif so - do scientific notation
3869 deca
3870 tfr a,b
3871 lda #2 ; force no scientific notation
3872 LBE36 deca ; subtract wo without affecting carry
3873 deca
3874 sta V47 ; save exponent - 0 is do not display in scientific notation
3875 stb V45 ; save number of places to left of decimal
3876 bgt LBE4B ; brif >= 1
3877 ldu COEFPT ; point to string buffer
3878 lda #'. ; put decimal
3879 sta ,u+
3880 tstb ; is there anything to left of decimal?
3881 beq LBE4B ; brif not
3882 lda #'0 ; store a zero
3883 sta ,u+
3884 LBE4B ldx #LBEC5 ; point to powers of 10
3885 ldb #0x80 ; set digit counter to 0x80
3886 LBE50 lda FPA0+3 ; add mantissa to power of 10
3887 adda 3,x
3888 sta FPA0+3
3889 lda FPA0+2
3890 adca 2,x
3891 sta FPA0+2
3892 lda FPA0+1
3893 adca 1,x
3894 sta FPA0+1
3895 lda FPA0
3896 adca ,x
3897 sta FPA0
3898 incb ; add one to digit counter
3899 rorb ; put carry into bit 7
3900 rolb ; set V if carry and sign differ
3901 bvc LBE50 ; brif positive mantissa or carry is 0 and negative mantissa
3902 bcc LBE72 ; brif negative mantissa
3903 subb #10+1 ; take 9's complement if adding mantissa
3904 negb
3905 LBE72 addb #'0-1 ; add ASCII bias
3906 leax 4,x ; move to next power of 10
3907 tfr b,a ; save digit
3908 anda #0x7f ; remove add/subtract flag
3909 sta ,u+ ; put in output
3910 dec V45 ; do we need a decimal yet?
3911 bne LBE84 ; brif not
3912 lda #'. ; put decimal
3913 sta ,u+
3914 LBE84 comb ; toggle bit 7 (add/sub flag)
3915 andb #0x80 ; only keep bit 7
3916 cmpx #LBEC5+9*4 ; done all places?
3917 bne LBE50 ; brif not
3918 LBE8C lda ,-u ; get last character
3919 cmpa #'0 ; was it 0?
3920 beq LBE8C ; brif so
3921 cmpa #'. ; decimal?
3922 bne LBE98 ; brif not
3923 leau -1,u ; move past decimal if it isn't needed
3924 LBE98 lda #'+ ; plus sign
3925 ldb V47 ; get scientific notation exponent
3926 beq LBEBA ; brif not scientific notation
3927 bpl LBEA3 ; brif positive exponent
3928 lda #'- ; negative sign for base 10 exponent
3929 negb ; switch to positive exponent
3930 LBEA3 sta 2,u ; put sign
3931 lda #'E ; put "E"
3932 sta 1,u
3933 lda #'0-1 ; init to ASCII 0 (compensate for INC)
3934 LBEAB inca ; bump digit
3935 subb #10 ; have we hit the correct one yet?
3936 bcc LBEAB ; brif not
3937 addb #'9+1 ; convert units digit to ASCII
3938 std 3,u ; put exponent in output
3939 clr 5,u ; put trailing NUL
3940 bra LBEBC ; go reset pointer
3941 LBEB8 sta ,u ; store last character
3942 LBEBA clr 1,u ; put NUL at the end
3943 LBEBC ldx #STRBUF+3 ; point to start of string
3944 rts
3945 LBEC0 fcb 0x80,0x00,0x00,0x00,0x00 ; packed FP 0.5
3946 LBEC5 fqb -100000000
3947 fqb 10000000
3948 fqb -1000000
3949 fqb 100000
3950 fqb -10000
3951 fqb 1000
3952 fqb -100
3953 fqb 10
3954 fqb -1
3955 LBEE9 lda FP0EXP ; get exponent of FPA0
3956 beq LBEEF ; brif 0 - don't flip sign
3957 com FP0SGN ; flip sign
3958 LBEEF rts
3959 ; Expand a polynomial of the form
3960 ; AQ+BQ^3+CQ^5+DQ^7..... where Q is FPA0 and X points to a table
3961 LBEF0 stx COEFPT ; save coefficient table pointer
3962 jsr LBC2F ; copy FPA0 to FPA3
3963 bsr LBEFC ; multiply FPA3 by FPA0
3964 bsr LBF01 ; expand polynomial
3965 ldx #V40 ; point to FPA3
3966 LBEFC jmp LBACA ; multiply FPA0 by FPA3
3967 LBEFF stx COEFPT ; save coefficient table counter
3968 LBF01 jsr LBC2A ; move FPA0 to FPA4
3969 ldx COEFPT ; get the current coefficient
3970 ldb ,x+ ; get the number of entries
3971 stb COEFCT ; save as counter
3972 stx COEFPT ; save new pointer
3973 LBF0C bsr LBEFC ; multiply (X) and FPA0
3974 ldx COEFPT ; get this coefficient
3975 leax 5,x ; move to next one
3976 stx COEFPT ; save new pointer
3977 jsr LB9C2 ; add (X) to FPA0
3978 ldx #V45 ; point X to FPA4
3979 dec COEFCT ; done all coefficients?
3980 bne LBF0C ; brif more left
3981 rts
3982 ; RND function
3983 RND jsr LBC6D ; set flags on FPA0
3984 bmi LBF45 ; brif negative - set seed
3985 beq LBF3B ; brif 0 - do random between 0 and 1
3986 bsr LBF38 ; convert to integer
3987 jsr LBC2F ; save range value
3988 bsr LBF3B ; get random number
3989 ldx #V40 ; point to FPA3
3990 bsr LBEFC ; multply (X) by FPA0
3991 ldx #LBAC5 ; point to FP 1.0
3992 jsr LB9C2 ; add 1 to FPA0
3993 LBF38 jmp INT ; return integer value
3994 LBF3B ldx RVSEED+1 ; move variable random number seed to FPA0
3995 stx FPA0
3996 ldx RVSEED+3
3997 stx FPA0+2
3998 LBF45 ldx RSEED ; move fixed seed to FPA1
3999 stx FPA1
4000 ldx RSEED+2
4001 stx FPA1+2
4002 jsr LBAD0 ; multiply them
4003 ldd VAD ; get lowest order product bytes
4004 addd #0x658b ; add a constant
4005 std RVSEED+3 ; save it as new seed
4006 std FPA0+2 ; save in result
4007 ldd VAB ; get high order extra product bytes
4008 adcb #0xb0 ; add upper bytes of constant
4009 adca #5
4010 std RVSEED+1 ; save as new seed
4011 std FPA0 ; save as result
4012 clr FP0SGN ; set result to positive
4013 lda #0x80 ; set exponent to 0 < FPA0 < 1
4014 sta FP0EXP
4015 lda FPA2+2 ; get a byte from FPA2
4016 sta FPSBYT ; save as extra precision
4017 jmp LBA1C ; go normalize FPA0
4018 RSEED fqb 0x40e64dab ; constant random number generator seed
4019 ; SIN function
4020 SIN jsr LBC5F ; copy FPA0 to FPA1
4021 ldx #LBFBD ; point to 2*pi
4022 ldb FP1SGN ; get sign of FPA1
4023 jsr LBB89 ; divide FPA0 by 2*pi
4024 jsr LBC5F ; copy FPA0 to FPA1
4025 bsr LBF38 ; convert FPA0 to an integer
4026 clr RESSGN ; set result to positive
4027 lda FP1EXP ; get exponent of FPA1
4028 ldb FP0EXP ; get exponent of FPA0
4029 jsr LB9BC ; subtract FPA0 from FPA1
4030 ldx #LBFC2 ; point to FP 0.25
4031 jsr LB9B9 ; subtract FPA0 from 0.25 (pi/2)
4032 lda FP0SGN ; get result sign
4033 pshs a ; save it
4034 bpl LBFA6 ; brif positive
4035 jsr LB9B4 ; add 0.5 (pi) to FPA0
4036 lda FP0SGN ; get sign of result
4037 bmi LBFA9 ; brif negative
4038 com RELFLG ; if 3pi/2 >= arg >= pi/2
4039 LBFA6 jsr LBEE9 ; flip sign of FPA0
4040 LBFA9 ldx #LBFC2 ; point to 0.25
4041 jsr LB9C2 ; add 0.25 (pi/2) to FPA0
4042 puls a ; get original sign
4043 tsta ; was it positive
4044 bpl LBFB7 ; brif so
4045 jsr LBEE9 ; flip result sign
4046 LBFB7 ldx #LBFC7 ; point to series coefficients
4047 jmp LBEF0 ; go calculate value
4048 LBFBD fcb 0x83,0x49,0x0f,0xda,0xa2 ; 2*pi
4049 LBFC2 fcb 0x7f,0x00,0x00,0x00,0x00 ; 0.25
4050 ; modified taylor series SIN coefficients
4051 LBFC7 fcb 6-1 ; six coefficients
4052 fcb 0x84,0xe6,0x1a,0x2d,0x1b ; -((2pi)^11)/11!
4053 fcb 0x86,0x28,0x07,0xfb,0xf8 ; ((2pi)^9)/9!
4054 fcb 0x87,0x99,0x68,0x89,0x01 ; -((2pi)^7)/7!
4055 fcb 0x87,0x23,0x35,0xdf,0xe1 ; ((2pi)^5)/5!
4056 fcb 0x86,0xa5,0x5d,0xe7,0x28 ; -(2pi)^3)/3!
4057 fcb 0x83,0x49,0x0f,0xda,0xa2 ; 2*pi
4058 ; these 12 bytes are unused
4059 fcb 0xa1,0x54,0x46,0x8f,0x13,0x8f,0x52,0x43
4060 fcb 0x89,0xcd,0xa6,0x81
4061 ; these are the hardware interrupt vectors (coco1/2 only)
4062 fdb SW3VEC
4063 fdb SW2VEC
4064 fdb FRQVEC
4065 fdb IRQVEC
4066 fdb SWIVEC
4067 fdb NMIVEC
4068 fdb RESVEC