Mercurial > hg > index.cgi

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