Mercurial > hg > index.cgi
view src/lwbasic.s @ 71:f4b2406d7352
Add numeric argument matching routine
Numeric calculations need to either match types or do type promotion to
matching types. Add a routine to handle that and have the routine through a
type mismatch if the types are not compatible or not numeric. Note that this
will require special handling for string concatenation and comparision which
are obviously not numeric.
| author | William Astle <lost@l-w.ca> |
|---|---|
| date | Sun, 02 Jul 2023 02:33:53 -0600 |
| parents | eb7c96671f5b |
| children | f492fa6f6dc8 |
line wrap: on
line source
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; LWBasic Version 0.1 ; Copyright © 2022 Lost Wizard Enterprises Incorporated ; ; This is LWBasic, a replacement Basic ROM system for the TRS-80 Color Computer which ; is most definitely not binary compatible with the stock ROMs. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; *pragmapush list *pragma nolist *pragma noexpandcond *pragma cescapes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Utility macros ; ; skip next byte; flags preserved skip1 macro noexpand fcb 0x21 ; opcode for BRN endm ; skip next byte and load nonzero to A skip1lda macro noexpand fcb 0x86 ; opcode for LDA immediate endm ; skip next byte and load nonzero to B skip1ldb macro noexpand fcb 0xc6 ; opcoe for LDB immediate endm ; skip next 2 bytes; clobbers flags skip2 macro noexpand fcb 0x8c ; opcode for CMPX immediate endm *pragmapop list ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Various constants console_curdel equ 10 ; delay between cursor blink cycles keyb_bufflen equ 64 ; keyboard ring buffer length keyb_repdeli equ 40 ; ticks before initial repeat (2/3 s) keyb_repdelr equ 6 ; 10 repeats per second keyb_caps equ 0x80 ; capslock enabled keyb_alt equ 0x04 ; alt pressed keyb_ctrl equ 0x02 ; ctrl pressed keyb_shift equ 0x01 ; shift pressed linebuffsize equ 0x100 ; the line input buffer (256 bytes) stringstacknum equ 20 ; number of entries on the anonymous string descriptor stack ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Data structure used for calculations. Calculations are handled via structurs called value accumulators. A value ; accumulator consists of a data type flag (at the end of the structure) and a data area whose layout varies based ; on the actual data type. The layouts for each value type are described below. ; ; A value type that is NULL (not set to anything) has type 0 (valtype_none) and the rest should be zero. ; ; A value accumulator has the following structure for floating point: ; Offset Length Contents ; 0 1 fp exponent ; 1 4 fp mantissa ; 5 1 fp sign ; 6 1 value type ; ; A value accumulator has the following structure for integers: ; Offset Length Contents ; 0 1 *unsued* ; 1 4 integer value (two's complement) ; 5 1 *unused* ; 6 1 value type ; ; A value accumulator has the following structure for a string: ; Offset Length Contents ; 0 2 string length ; 2 2 *reserved for string data pointer expansion, must be zero* ; 4 2 string data pointer ; 6 1 value type ; ; Value type constants valtype_none equ 0 ; unknown value type valtype_int equ 1 ; integer (32 bit) value (signed) valtype_float equ 2 ; float type (40 bit) value valtype_string equ 3 ; string type (16 bit length, 16(32) bit data pointer ; Value accumulator structure definitions val.type equ 6 ; value type offset val.fpexp equ 0 ; fp exponent offset val.fpmant equ 1 ; fp mantissa offset val.fpsign equ 5 ; fp sign offset val.int equ 1 ; integer offset val.strlen equ 0 ; string length offset val.strptr equ 4 ; string data pointer (low word) val.size equ 7 ; size of a value accumulator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ifdef COCO3 ; GIME INIT0 GIME_COCO equ 0x80 ; Set for coco2 compatible mode (video display) GIME_MMUEN equ 0x40 ; Set to enable MMU GIME_IEN equ 0x20 ; GIME IRQ enable GIME_FEN equ 0x10 ; GIME FIRQ enable GIME_FExx equ 0x08 ; Enable constant RAM at 0xFExx (comes from block 0x3f) GIME_SCS equ 0x04 ; Set to enable standard SCS (switches 0xFF5x) GIME_ROME16 equ 0x00 ; 16K internal, 16K external ROM mode GIME_ROME32 equ 0x03 ; 32K external ROM GIME_ROMI32 equ 0x02 ; 32K internal ROM ; GIME INIT1 GIME_TMRFAT equ 0x20 ; TIMER ticks approx every 279.365 ns GIME_TMRSLOW equ 0x00 ; TIMER ticks approx every 63.695 µs GIME_TASK0 equ 0x00 ; MMU task 0 GIME_TASK1 equ 0x01 ; MMU task 1 ; GIME interrupt enable/status bits GIME_ITIMER equ 0x20 ; TIMER interrupt (timer reaches 0) GIME_IHBORD equ 0x10 ; HSYNC interrupt (falling edge) GIME_IVBORD equ 0x08 ; VSYNC interrupt (falling edge) GIME_ISERIAL equ 0x04 ; Falling edge of signal on pin 4 of serial port GIME_IKEYBOARD equ 0x02 ; Interrupt if a 0 bit appears on bits 6-0 of PIA0.DA GIME_ICART equ 0x01 ; Interrupt on falling edge of pin 8 of cartridge port ; GIME VMODE GIME_BP equ 0x80 ; enable bit plane mode GIME_BPI equ 0x20 ; colour burst phase inversion (composite output only) GIME_MONO equ 0x10 ; disable colour burst (composite output only) GIME_H50 equ 0x08 ; set to 50Hz operation GIME_LPR1 equ 0x00 ; one line per row GIME_LPR2 equ 0x02 ; two lines per row (also works on graphics) GIME_LPR8 equ 0x03 ; 8 lines per row GIME_LPR9 equ 0x04 ; 9 lines per row GIME_LPR10 equ 0x05 ; 10 lines per row GIME_LPR11 equ 0x06 ; 11 lines per row GIME_LPRINF equ 0x07 ; "infinite" lines per row ; GIME VRES GIME_LPF192 equ 0x00 ; 192 lines on screen GIME_LPF200 equ 0x40 ; 200 lines on screen (actually 199 due to hardware bug) GIME_LPF225 equ 0x60 ; 225 lines on screen GIME_BPR16 equ 0x00 ; 16 bytes per row GIME_BPR20 equ 0x04 ; 20 bytes per row GIME_BPR32 equ 0x08 ; 32 bytes per row GIME_BPR40 equ 0x0c ; 40 bytes per row GIME_BPR64 equ 0x10 ; 64 bytes per row GIME_BPR80 equ 0x14 ; 80 bytes per row GIME_BPR128 equ 0x18 ; 128 bytes per row GIME_BPR160 equ 0x1c ; 160 bytes per row GIME_TXT32 equ 0x00 ; 32 characters per row GIME_TXT40 equ 0x04 ; 40 characters per row GIME_TXT64 equ 0x10 ; 64 characters per row GIME_TXT80 equ 0x14 ; 80 characters per row GIME_BPP1 equ 0x00 ; 1 bit per pixel GIME_BPP2 equ 0x01 ; 2 bits per pixel GIME_BPP4 equ 0x02 ; 4 bits per pixel GIME_TXTATTR equ 0x01 ; text attributes enabled endc ifdef COCO3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Stuff on the fixed memory page org 0xfe00 rmb 0xed ; unused INT.FLAG rmb 1 ; validity flag INT.SWI3 rmb 3 ; SWI3 bounce vector INT.SWI2 rmb 3 ; SWI2 bounce vector INT.FIRQ rmb 3 ; FIRQ bounce vector INT.IRQ rmb 3 ; IRQ bounce vector INT.SWI rmb 3 ; SWI bounce vector INT.NMI rmb 3 ; NMI bounce vector endc ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Hardware definitions for the I/O page org 0xff00 PIA0 equ * ; Keyboard PIA PIA0.DA rmb 1 ; PIA0 data/direction A PIA0.CA rmb 1 ; PIA0 control A PIA0.DB rmb 1 ; PIA0 data/direction B PIA0.CB rmb 1 ; PIA0 control B rmb 28 ; mirror images of PIA0 PIA1 equ * ; DA/misc stuff PIA1.DA rmb 1 ; PIA1 data/direction A PIA1.CA rmb 1 ; PIA1 control A PIA1.DB rmb 1 ; PIA1 data/direction B PIA1.CB rmb 1 ; PIA1 control B rmb 28 ; mirror images of PIA1 rmb 16 ; SCS/Disk controller rmb 16 ; second half of SCS area rmb 32 ; miscelaneous hardware ifdef COCO3 rmb 16 ; *reserved* (unused but the GIME drives them) GIME.INIT0 rmb 1 ; basic GIME system config GIME.INIT1 rmb 1 ; MMU task and timer rate GIME.IRQ rmb 1 ; GIME IRQ enable/status register GIME.FIRQ rmb 1 ; GIME FIRQ enable/status register GIME.TIMER rmb 2 ; GIME programmable timer rmb 2 ; *reserved* GIME.VMODE rmb 1 ; GIME video mode setting GIME.VRES rmb 1 ; GIME video resolution setting rmb 1 ; *reserved* (used for MMU expansion on some memory boards) GIME.BORDER rmb 1 ; GIME border colour GIME.VSCROLL rmb 1 ; vertical scroll offset register/VDG screen mode variation GIME.VOFFSET rmb 2 ; address of video memory (8 byte increments) GIME.HOFFSET rmb 1 ; horizontal scroll offset GIME.MMU equ * ; MMU registers (two tasks) GIME.MMU0 rmb 8 ; MMU task 0 GIME.MMU1 rmb 8 ; MMU task 1 GIME.PALETTE rmb 16 ; Palette registers else rmb 64 ; unused on Coco 1/2 (GIME on Coco 3) endc SAMREG equ * ; the SAM configuration register SAM.V0CLR rmb 1 ; SAM video mode bits SAM.V0SET rmb 1 SAM.V1CLR rmb 1 SAM.V1SET rmb 1 SAM.V2CLR rmb 1 SAM.V2SET rmb 1 SAM.F0CLR rmb 1 ; SAM screen address bits SAM.F0SET rmb 1 SAM.F1CLR rmb 1 SAM.F1SET rmb 1 SAM.F2CLR rmb 1 SAM.F2SET rmb 1 SAM.F3CLR rmb 1 SAM.F3SET rmb 1 SAM.F4CLR rmb 1 SAM.F4SET rmb 1 SAM.F5CLR rmb 1 SAM.F5SET rmb 1 SAM.F6CLR rmb 1 SAM.F6SET rmb 1 SAM.P1CLR rmb 1 ; SAM "page 1" selection (or extra memory type flag) SAM.P1SET rmb 1 SAM.R0CLR rmb 1 ; SAM R0 bit (address dependent speedup, not used on Coco3) SAM.R0SET rmb 1 SAM.R1CLR rmb 1 ; SAM R1 bit (full speedup/coco 3 speedup) SAM.R1SET rmb 1 SAM.M0CLR rmb 1 ; SAM M0/M1 bits (memory type, not used on Coco3) SAM.M0SET rmb 1 SAM.M1CLR rmb 1 SAM.M1SET rmb 1 SAM.TYCLR rmb 1 ; force ROM mode (map type 0) SAM.TYSET rmb 1 ; set RAM mode (map type 1) rmb 18 ; *MPU reserved* CPU.SWI3 rmb 2 ; CPU SWI3 vector CPU.SWI2 rmb 2 ; CPU SWI2 vector CPU.FIRQ rmb 2 ; CPU FIRQ vector CPU.IRQ rmb 2 ; CPU IRQ vector CPU.SWI rmb 2 ; CPU SWI vector CPU.NMI rmb 2 ; CPU NMI vector CPU.RESET rmb 2 ; CPU RESET/startup vector ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Start of memory which has the direct page and other data. org 0 dpstart equ * ; start of direct page zero rmb 2 ; constant zero word used for faster zeroing of 16 bit registers binval rmb 2 ; arbitary binary value, usually a line number or integer memtop rmb 2 ; absolute top of memory in 64K memory map memsize rmb 2 ; top of memory not reserved freetop rmb 2 ; top of free memory (bottom of string space) stringtab rmb 2 ; bottom of used string space stackptr rmb 2 ; bottom of the "stack frame" stack (the actual stack is below here) progtext rmb 2 ; pointer to start of program text vartab rmb 2 ; pointer to start of integer scalars objecttab rmb 2 ; pointer to start of arrays and other variable sized objects freestart rmb 2 ; pointer to start of unallocated memory readlinenoecho rmb 1 ; if nonzero, the readline routine won't echo its input console_curptr rmb 2 ; current cursor pointer for console driver console_blnkdel rmb 1 ; cursor blink delay console_truelc rmb 1 ; set to nonzero if the console supports true lower case (gfx, etc.) filenum rmb 1 ; current input/output channel fileeof rmb 1 ; flag for whether last read detected EOF keyb_flags rmb 1 ; shift flags for the keyboard keyb_joystate rmb 1 ; joystick button state keyb_repdel rmb 1 ; repeat delay keyb_curscan rmb 1 ; current repeating scan code keyb_buffw rmb 2 ; keyboard ring buffer write pointer keyb_buffr rmb 2 ; keyboard ring buffer read pointer curline rmb 2 ; pointer to current line contline rmb 2 ; pointer to line for CONT contstmt rmb 2 ; interpretation pointer for CONT curstmt rmb 2 ; start of statement currently being interpreted endflag rmb 1 ; 00 = END, FF = STOP stringstackptr rmb 2 ; anonymous string descriptor stack pointer tok_skipkw rmb 1 ; flag for when skipping an unrecognized keyword tok_skipdt rmb 1 ; flag for when processing DATA tok_kwtype rmb 1 ; primary/secondary type flag for tokens tok_kwnum rmb 1 ; the actual token number tok_kwmatchl rmb 1 ; the length of the best match during lookup tok_kwmatch rmb 2 ; the current best matched token number val0 rmb val.size ; value accumulator 0 val1 rmb val.size ; value accumulator 1 rmb 0x71-* ; align RSTFLG/RSTVEC for stock ROM compatibility RSTFLG rmb 1 ; 0x55 if RSTVEC is valid RSTVEC rmb 2 ; points to warm start routine (must start with NOP) inputptr rmb 2 ; pointer to current program execution location rmb 0x100-* ; make sure the stuff that isn't direct page is outside of it SW3VEC rmb 3 ; SWI3 vector (for compatibility) SW2VEC rmb 3 ; SWI2 vector (for compatibility) SWIVEC rmb 3 ; SWI vector (for compatibility) NMIVEC rmb 3 ; NMI vector (for compatibility) IRQVEC rmb 3 ; IRQ vector (for compatibility) FRQVEC rmb 3 ; FIRQ vector (for compatibility) keyb_state rmb 8 ; rollover table state keyb_buff rmb keyb_bufflen ; the keyboard ring buffer linebuff rmb linebuffsize ; the line input buffer tokebuff rmb linebuffsize+50 ; make it as long as line buffer plus a margin stringstack rmb 5*stringstacknum ; reserve space for the anonymous string descriptor stack stringstackend equ * ; end of string stack buffer ifne *&0x1ff rmb 0x200-(*&0x1ff) endc textscreen rmb 0x200 ; the actual text screen (must be on 512 byte alignment) heapstart equ * ; start of dynamically allocated stuff ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; The heap has the following items in order: ; ; Program text: preceded by a NUL and pointed to by progtext ; Variable table: pointed to by vartab; contains records for all scalar and array variables ; Free space: unused memory between the object table and the stack; pointed to by freestart ; The stack: grows downward from the bottom of string space, pointed to by the stack pointer, obviously ; String space: garbage collected non-constant string data pointed to by freetop ; Reserved memory: immediately above string space; pointed to by memsize ; Actual top of RAM: top of reserved memory; pointed to by memtop ; ; The variable table consists of several symbol tables defined as follows: ; ; Pointer Size of entry Variable types ; vartabint 4 Integer scalars ; vartablong 6 Long integer scalars ; vartabfloat 7 Floating point scalars ; vartabstring 6 String scalars ; ; Each entry starts with 2 bytes for the variable name followed by the data payload. org 0x8000 ; the hardware puts the ROMs here; it's not negotiable ROMSTART equ * START orcc #0x50 ; make sure interrupts are disabled if we come here in an unusual way ifdef COCO3 ldu #gime_inite ; point to end of GIME initializer ldx #GIME.INIT0+(gime_inite-gime_init) ; point to end of GIME registers ldb #gime_inite-gime_init ; number of bytes to transfer initc0 lda ,-u ; copy byte to GIME (count down so we init MMU before turning it on) sta ,-x decb ; done? bne initc0 ; brif not endc ldd #0xff34 ; initizer for below tfr a,dp ; set DP to I/O page setdp 0xff ; tell assembler about DP value clr PIA0.CA ; set PIA0 A to direction mode clr PIA0.CB ; set PIA0 B to direction mode clr PIA0.DA ; set PIA0 A to all inputs (comparator, keyboard rows) sta PIA0.DB ; set PIA0 B to all outputs (keyboard columns) stb PIA0.CA ; set PIA0 A to data mode, interrupt disabled, MUX to source 0 stb PIA0.CB ; set PIA0 B to data mode, interrupt disabled, MUX to source 0 clr PIA1.CA ; set PIA1 A to direction mode clr PIA1.CB ; set PIA1 B to direction mode deca ; set PIA1 A bits 7-1 output (DAC, RS232), 0 input (cassette) sta PIA1.DA lda #0xf8 ;* set PIA1 B bits 7-3 output (VDG stuff), 2-0 input (single bit sound, sta PIA1.DB ;* RS232 input, ram size input) stb PIA1.CA ; set PIA1 A to data mode, interrupt disabled, cassette motor off stb PIA1.CB ; set PIA1 B to data mode, interrupt disabled, sound off lda #2 ; set RS232 output to "marking" (stop bit) sta PIA1.DA lda #16 ; clear 16 SAM register bits ldu #SAMREG ; point to SAM register bits init0 sta ,u++ ; clear SAM bit deca ; done all? bne init0 ; brif not ; set the SAM to point to the text screen, which the code will handle at any ; arbitrary 512 byte aligned address in memory ifne (textscreen)&0x200 sta SAM.F0SET endc ifne (textscreen)&0x400 sta SAM.F1SET endc ifne (textscreen)&0x800 sta SAM.F2SET endc ifne (textscreen)&0x1000 sta SAM.F3SET endc ifne (textscreen)&0x2000 sta SAM.F4SET endc ifne (textscreen)&0x4000 sta SAM.F5SET endc ifne (textscreen)&0x8000 sta SAM.F6SET endc ifdef COCO2B ; The following SAM configuration sequence is different from the one in the usual ; one used by the earlier models of the Coco because the Coco2B has the '785 variant ; of the SAM instead of the '783 variant. The '785 variant supports 16Kx4 RAMs which ; are used in Coco2B systems. Hence why there is a different version of this ROM ; just for the Coco2B. clr PIA0.DB ; strobe RAM size low ldb #4 ; is input low? bitb PIA1.DB beq init1 ; brif not sta SAM.M0SET ; program SAM for 16Kx4 RAMs sta SAM.P1SET skip2 init1 sta SAM.M1SET ; program SAM for 64Kx1 RAMs else ifndef COCO3 ; Detect the installed memory size so the SAM ('783 variant) can be correctly ; programmed for the installed memory. Note that this sequence is replaced with ; a different one for the Coco2B which has the '785 variant of the SAM. ldb #0xff ; strobe RAM size high stb PIA0.DB ldb #4 ; mask for ram size check bitb PIA1.DB ; is the bit set on ram size input? beq init2 ; brif not - 4Kx1 RAMs sta PIA0.DB ; clear RAM size output to see what happens (A is 0 from above) bitb PIA1.DB ; is it set now? beq init1 ; brif not - 64Kx1 RAMs leau -2,u ; adjust pointer so we set the other RAM size bit for the SAM (16Kx1) init1 sta -3,u ; set M0 (16Kx1) or M1 (64Kx1) endc endc init2 tfr a,dp ; set DP to bottom of memory (A is 0 from above) setdp 0 ; tell assembler about it lds #textscreen ; put the stack just below the text screen ifdef COCO3 ; Check if we need to do a ROM/RAM copy, which will happen if the interrupt vectors are ; not flagged valid OR the reset vector isn't valid ldb INT.FLAG ; are the bounce vectors valid? cmpb #0x55 bne initc4 ; brif not - do ROM/RAM copy ldb RSTFLG ; is reset vector valid? bne initc2 ; brif not - check secondary location ldx RSTVEC ; get reset vector ldb ,x ; is it valid?\ cmpb #0x12 bne initc2 ; brif not initc1 jmp ,x ; transfer control to warm start routine initc2 clr GIME.MMU0 ; check again with block 0 in the direct page ldb RSTFLG ; get new RSTFLG cmpb #0x55 ; valid? bne initc3 ; brif not ldx RSTVEC ; get new RSTVEC ldb ,x ; is it valid? cmpb #0x12 beq initc1 ; brif so - transfer control initc3 ldb #0x38 ; restore MMU stb GIME.MMU0 initc4 ldx #initc6 ; point to helper ldu #textscreen ; point to text screen ldb #initc7-initc6 ; bytes to copy initc5 lda ,x+ ; copy byte sta ,u+ decb ; done? bne initc5 ; brif not ldu #0x8000 ; point to start of ROM jmp textscreen ; transfer control to helper in RAM initc6 sta SAM.TYCLR ; drop to ROM mode pulu d,x,y,s ; grab 8 bytes sta SAM.TYSET ; go to RAM mode pshu d,x,y,s ; stick the bytes in RAM leau 8,u ; move to next 8 bytes cmpu #0xfe00 ; end of stuff to copy? blo initc6 ; brif not jmp initc7 ; go back to mainline initc7 lds #textscreen ; reset stack to somewhere safe lda #0x12 ; activate ROM warm start handler sta warmstart ldx #INT.FLAG ; point to bounce vector destination ldu #int_init ; point to initializer for bounce vectors ldb #int_inite-int_init ; number of bytes to copy initc8 lda ,u+ ; copy byte sta ,x+ decb ; done? bne initc8 ; brif not ; now recheck for warm start in case ROM/RAM copy made things valid endc ldb RSTFLG ; is the reset vector valid? cmpb #0x55 bne coldstart ; brif not - do cold start ldx RSTVEC ; get warm start routine pointer ldb ,x ; does it start with NOP? cmpb #0x12 bne coldstart ; brif not - do cold start jmp ,x ; transfer control to warm start routine ifdef COCO3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; GIME register initializer gime_init fcb GIME_COCO|GIME_MMUEN|GIME_FExx|GIME_SCS|GIME_ROMI32 ; enable MMU, SCS, constant page, internal ROM fcb GIME_TASK0 ; use MMU task 0 fcb 0 ; do not enable IRQ sources fcb 0 ; do not enable FIRQ sources fdb 0xfff ; set timer to max value fdb 0 ; *reserved placeholder* fcb 0,0,0,0 ; SG4 screen settings with black border fcb 0x0f,0xe0,0x00,0x00 ; (puts screen in bottom 64K of memory) fcb 0x38,0x39,0x3a,0x3b ; MMU task 0 (bottom of top 64K of RAM) fcb 0x3c,0x3d,0x3e,0x3f ; (ROM shadow must be in 3c...3f) fcb 0x38,0x39,0x3a,0x3b ; MMU task 1 (copy of task 0) fcb 0x3c,0x3d,0x3e,0x3f fcb 18,54,9,36,63,27,45,38 ; palette values (RGB) fcb 0,18,0,63,0,18,0,38 gime_inite equ * int_init fcb 0x55 ; vectors valid flag jmp SW3VEC ; bounce to stock ROM compatibility vector jmp SW2VEC ; bounce to stock ROM compatibility vector jmp FRQVEC ; bounce to stock ROM compatibility vector jmp IRQVEC ; bounce to stock ROM compatibility vector jmp SWIVEC ; bounce to stock ROM compatibility vector jmp NMIVEC ; bounce to stock ROM compatibility vector int_inite equ * endc ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Cold start handling coldstart ldx #dpstart ; point to start of direct page ldd #0 ; set up for blanking coldstart0 std ,x++ ; blank a couple of bytes cmpx #textscreen ; end of low memory? blo coldstart0 ; brif not ifndef COCO3 ; This is the memory size detection sequence. This runs through memory starting at the bottom of memory ; and stops when it reaches something that can't be modified successfully. This is basically the same ; algorithm used by the stock ROM. It takes less space than doing a more pointed set of probes. The end ; result will be X pointing to the byte one below the top of RAM. This is intentional to ensure there ; is one writeable byte at the top of string space. Note that X will point to the byte after the end ; of the text screen when we get here. ldx #heapstart ; point to start of heap coldstart1 lda 2,x ; get original value at test location coma ; invert all bits sta 2,x ; write it to the memory location cmpa 2,x ; did it take? bne coldstart2 ; brif not com 2,x ; restore memory byte leax 1,x ; move pointer forward bra coldstart1 ; go check next byte else ; For the Coco3, we do not need to concern ourselves about where the top actual memory is so we don't ; bother doing a memory scan in the default 64K memory map. Because we always run from RAM, we can actually ; set the top of memory to the actual top of the 32K space without having to ensure there is an extra byte ; available above the string space. ldx #ROMSTART-1 ; point to top of memory endc coldstart2 stx memtop ; save absolute top of memory stx memsize ; save top of unreserved memory stx stringtab ; mark string space as empty leax -200,x ; allocate 200 bytes of string space stx freetop ; save top of free memory clr ,-x ; make a hole for the "end of call stack" flag stx stackptr ; save the new call stack pointer leas ,x ; put the actual stack below the above ldx #heapstart ; point to start of free memory clr ,x+ ; put a NUL before the start of the program stx progtext ; put the start of the program there clr ,x+ ; put a NULL pointer to mark end of program clr ,x+ stx vartab ; put start of integer variables at end of program stx objecttab ; also put the start of large objects there stx freestart ; mark the start of free memory lda #keyb_caps ; enable caps lock but disable all other shift states sta keyb_flags ldx #warmstart ; set up warm start handler stx RSTVEC lda #0x55 ; activate warm start handler sta RSTFLG ldd #0x7e3b ; opcodes for JMP extended and RTI ldx #irqhandler ; enable IRQ handler with a JMP at the vector sta IRQVEC stx IRQVEC+1 sta FRQVEC ; initialize FIRQ handler with JMP ldx #firqhandler stx FRQVEC+1 stb NMIVEC ; initialize NMI to RTI stb SW3VEC ; initialize SWI3 to RTI stb SW2VEC ; initialize SWI2 to RTI stb SWIVEC ; initialize SWI to RTI ldx #greeting ; display greeting jsr console_outstr bra warmstartb ; finish up initialization ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Warm start handling ifdef COCO3 warmstart fcb 0xff ; set to 0xff to force ROM/RAM copy on reset else warmstart nop ; flag warm start routine as valid endc jsr console_clear ; clear screen clr filenum ; reset I/O channel to the screen warmstartb jsr keyb_reset ; reset the keyboard lda #0x35 ; enable VSYNC interrupt in PIA sta PIA0.CB andcc #0xaf ; enable interrupts at the cpu jmp immediate ; go start immediate mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; System startup message ; (start with form feed to clear screen; saves 2 bytes over 'jsr console_clear' in cold start) greeting fcc '\fLWBASIC VERSION 2022.0\r\n' fcc 'COPYRIGHT (C) 2022 BY LOST\r\n' fcc 'WIZARD ENTERPRISES INC.\r\n' fcn '\n' ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Check for BREAK; this needs to check the keyboard directly instead of just using the usual key fetching routine so ; we don't interfere with keyboard buffering if BREAK isn't pressed. We also need to scan the keyboard directly for this ; so we react even if the keyboard buffer is full. If BREAK is pressed, the keyboard buffer is emptied. breakcheck lda #0xfb ; strobe column for BREAK sta PIA0.DB clra ; clear carry for no BREAK lda PIA0.DA ; read rows bita #0x40 ; is BREAK down? bne breakcheck0 ; brif not - check for SHIFT-@ sync ; wait for interrupt to scan keyboard bsr keyb_clearbuff ; reset keyboard buffer coma ; flag BREAK breakcheck1 rts breakcheck0 lda #0x7f ; check for SHIFT sta PIA0.DB lda PIA0.DA bita #0x40 ; shift? bne breakcheck1 ; brif not lda #0xfe ; check for @ sta PIA0.DB lda PIA0.DA bita #1 ; @? bne breakcheck1 ; brif not bsr keyb_clearbuff ; clear buffer breakcheck2 sync ; wait for keyboard to actually be scanned bsr keyb_getkey bcs breakcheck2 ; brif no key down bra breakcheck ; go do the break/pause check dance again ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Empty the keyboard buffer keyb_clearbuff ldx #keyb_buff ; point to start of buffer stx keyb_buffr ; set both pointers to the start stx keyb_buffw rts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; IRQ handler ; ; Note that the interrupt flag in the PIA is cleared at the start of the interrupt handler. That means that if it takes ; a long time to process this interrupt, or processing this interrupt was delayed somewhat, it is far less likely that ; an interrupt gets missed. In that case, we may end up re-interrupting immediately on RTI, but it should reduce the ; number of missed interrupts. irqhandler lda PIA0.CB ; was it VSYNC? bmi irqhandler0 ; brif so lda PIA0.DA ; clear HSYNC flag so we don't get stuck if it gets enabled ifdef COCO3 lda GIME.IRQ ; clear GIME IRQ state flags endc rti irqhandler0 lda PIA0.DB ; clear VSYNC flag clra ; make sure DP is pointing to the right place tfr a,dp lda console_blnkdel ; is the cursor blinking? beq irqhandler1 ; brif not dec console_blnkdel ; time to cycle cursor? bne irqhandler1 ; brif not lda #console_curdel ; reset blink counter sta console_blnkdel lda [console_curptr] ; get character at cursor adda #0x10 ; move to next colour ora #0x8f ; force it to be a full 4x4 colour block sta [console_curptr] ; update cursor on screen irqhandler1 bsr keyb_read ; go handle the keyboard rti ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; FIRQ handler ; ; This handler is present to prevent accidentally enabling the interrupt and thus hanging to system. It may seem to be ; a waste of code space, but consider it a self defense situation. firqhandler pshs a ; need a scratch register ifdef COCO3 lda GIME.FIRQ ; clear GIME FIRQ state flags endc lda PIA1.DA ; clear interrupt flags lda PIA1.DB lda PIA1.CA ; disable interrupts to prevent system hang anda #0xfe sta PIA1.CA lda PIA1.CB anda #0xfe sta PIA1.CB puls a ; restore register rti ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Console keyboard input driver ; ; Reset the keyboard state, which means clearing the buffer and state flags keyb_reset bsr keyb_clearbuff ; clear keyboard buffer lda keyb_flags ; reset keyboard state flags but keep capslock anda #keyb_caps sta keyb_flags clr keyb_joystate ; clear joystick button state clr keyb_curscan ; stop any keyboard repeating ldx #0xffff ; mark all key state as "unpressed" stx keyb_state stx keyb_state+2 stx keyb_state+4 stx keyb_state+6 rts ; Read character from keyboard ring buffer; return with C set if buffer empty; this doesn't actually need to have ; interrupts disabled because the interrupt only ever updates the write pointer and then only to increase it. As a ; result, worst case is that we don't detect the contents added to the buffer on this call and have to wait for the ; next. keyb_getkey pshs x ; save register ldx keyb_buffr ; get read pointer cmpx keyb_buffw ; same as write pointer? bne keyb_getkey0 ; brif not - we have a result coma ; set carry for empty buffer puls x,pc ; restore register and return keyb_getkey0 lda ,x+ ; get character from buffer cmpx #keyb_buff+keyb_bufflen ; did we run off end of buffer? blo keyb_getkey1 ; brif not ldx #keyb_buff ; reset to start keyb_getkey1 stx keyb_buffr ; save new read pointer andcc #0xfe ; flag key retrieved puls x,pc ; restore register and return ; The PIA reading loop is specifically set up to NOT read PIA0.DB to avoid prematurely clearing the VSYNC interrupt flag ; since that could lead to missing interrupts. Reading PIA0.DA will clear the HSYNC interrupt flag but that's less of a ; problem because that interrupt is basically useless. ; ; As a note, doing the PIA read in a loop ends up using an extra 27 CPU cycles for the BCS instruction. However, it ; saves 70 code bytes. The trade off seems worth it in this case. ; ; Once keyboard state is read, we do the following: ; ; * update the state of SHIFT, CTRL, ALT ; * decode all other keys in a loop keyb_read0a pshs b ; save flag bit ldb a,y ; get state flag bitb #0x40 ; did it change state? bne keyb_read0d ; brif so puls b,pc ; clean up and return keyb_read0d andb #0xbf ; flag it as not changed stb a,y ldb a,u ; get current modifier state eorb #0x40 ; flip the state bit stb a,u ; save new state flags bitb #0x40 ; Z set if not down puls b ; get back flag bit beq keyb_read0b ; brif key is pressed comb ; invert bit flag andb keyb_flags ; clear bit in flags bra keyb_read0c ; finish up keyb_read0b orb keyb_flags ; set the flag keyb_read0c stb keyb_flags ; update flags rts keyb_read leas -9,s ; make temporary buffer leay 1,s ; point to temporary state buffer clra ;* set to 0xff with C clear; start by strobing no columns for joystick deca ;* then rotate the 0 bit through to do the actual keyboard columns ldu #keyb_state ; point to end of keyboard state buffer sta PIA0.DB ; strobe no columns ldb PIA0.DA ; get joystick button state stb keyb_joystate ; save it for later when needed andb #0x7f ; mask off comparator (pretend "button" down) stb ,s ; save button/comparator state mask rola ; set up for first column keyb_read0 sta PIA0.DB ; set column strobe ldb PIA0.DA ; read row data eorb ,u+ ; set bits if state changed andb ,s ; mask off comparator and active buttons stb ,y+ ; save state change information rola ; shift to next column bcs keyb_read0 ; brif we haven't done the last column sta PIA0.DB ; reset column strobe to none ldd #0xff00|keyb_shift bsr keyb_read0a ldd #0xfc00|keyb_ctrl bsr keyb_read0a ldd #0xfb00|keyb_alt bsr keyb_read0a keyb_read3 ldd #0x0701 ; initialize bit probe and counter keyb_read4 leay -1,y ; move pointers to next byte leau -1,u keyb_read5 bitb ,y ; did this key change state? bne keyb_read7 ; brif so keyb_read6 adda #8 ; adjust scan code lslb ; shift bit probe bpl keyb_read5 ; brif we haven't done all bits ldb ,y ; update state flags for this byte eorb ,u stb ,u ldb #1 ; reset bit probe anda #0x07 ; reset scan code deca ; adjust for next column bpl keyb_read4 ; brif not - do another leas 9,s ; clean up stack ldb keyb_curscan ; is key repeating? bne keyb_read9 ; brif so keyb_reada rts keyb_read7 bitb ,u ; get current state bne keyb_read8 ; brif key pressed (make) cmpa keyb_curscan ; is it the currently repeating key? bne keyb_read6 ; brif not - don't need to do anything clr keyb_curscan ; clear the current repeat bra keyb_read6 keyb_read8 sta keyb_curscan ; set the current scan code that is repeating pshs d ; save current bit probe and scan code ldb #keyb_repdeli ; intialize repeat delay stb keyb_repdel bsr keyb_tobuff ; decode key to buffer puls d ; restore scan code and bit probe bra keyb_read6 ; go handle the next bit keyb_read9 dec keyb_repdel ; is it time to repeat it? bne keyb_reada ; brif not ldb #keyb_repdelr ; reset repeat delay stb keyb_repdel lda keyb_curscan ; get current scan code keyb_tobuff tsta ; @? beq keyb_tobuff7 ; brif so cmpa #26 ; is it alpha or @? bhi keyb_tobuff6 ; brif not ldb keyb_flags ; get shift flags bitb #keyb_ctrl|keyb_alt ; ALT or CTRL? bne keyb_tobuff4 ; brif one or both ora #0x60 ; make lower case bitb #keyb_caps ; capslock enabled? beq keyb_tobuff0 ; brif not eora #0x20 ; flip to upper case keyb_tobuff0 bitb #keyb_shift ; shifted? beq keyb_tobuff1 ; brif not eora #0x20 ; flip case if shifted keyb_tobuff1 ldx keyb_buffw ; get write pointer for keyboard buffer sta ,x+ ; put it in the buffer cmpx #keyb_buff+keyb_bufflen ; end of buffer? blo keyb_tobuff2 ; brif not ldx #keyb_buff ; reset pointer to start keyb_tobuff2 cmpx keyb_buffr ; did we run into the read pointer? beq keyb_tobuff3 ; brif so - there wasn't room so don't save pointer stx keyb_buffw ; update the write pointer keyb_tobuff3 rts keyb_tobuff4 bitb #keyb_alt ; is ALT? beq keyb_tobuff1 ; brif not - scan code is CTRL-<letter> code ora #0x80 ; set bit 7 for "ALT" codes bitb #keyb_shift ; shifted? beq keyb_tobuff5 ; brif not ora #0x20 ; set bit 5 keyb_tobuff5 bitb #keyb_ctrl ; ctrl? beq keyb_tobuff1 ; brif not - stash it in the buffer ora #0x40 ; set bit 6 for "ctrl bra keyb_tobuff1 ; stash it the buffer keyb_tobuff6 suba #26 ; codes above 26 down to 1; @ will be 0 keyb_tobuff7 cmpa #6 ; is it "0"? bne keyb_tobuff8 ; brif not ldb keyb_flags ; get shift flags bitb #keyb_shift|keyb_ctrl ; CTRL-0 or SHIFT-0? beq keyb_tobuff8 ; brif not - not "capslock" eorb #keyb_caps ; flip the capslock state stb keyb_flags keyb_tobuffa rts ; and don't put it in the buffer keyb_tobuff8 cmpa #25 ; is it at or above ALT? blo keyb_tobuff9 ; brif not suba #2 ; close gap for ALT/CTRL keyb_tobuff9 ldb #8 ;* 8 codes; multiply by 8 and move to B mul ;* ldx #keyb_codetab ; point to special code table abx ; now X points to the base entry in the table ldb keyb_flags ; get shift flags andb #keyb_shift|keyb_ctrl|keyb_alt ; keep only shift/ctrl/alt lda b,x ; fetch key code beq keyb_tobuffa ; brif no code to return bra keyb_tobuff1 ; go stash it in the buffer ; This is the keyboard code table; there are 8 bytes per entry in the following order: ; 0: unmodified ; 1: shift ; 2: ctrl ; 3: ctrl-shift ; 4: alt ; 5: alt-shift ; 6: alt-ctrl ; 7: alt-ctrl-shift ; ; No entries for ALT, CTRL, SHIFT, or letters keyb_codetab fcb 0x40,0x13,0x40,0x40,0x80,0xa0,0xc0,0xe0 ; @ fcb 0x5e,0x5f,0x00,0x00,0x00,0x00,0x00,0x00 ; <UP> fcb 0x0a,0x5b,0x00,0x00,0x00,0x00,0x00,0x00 ; <DOWN> fcb 0x08,0x15,0x00,0x00,0x00,0x00,0x00,0x00 ; <LEFT> fcb 0x09,0x5d,0x00,0x00,0x00,0x00,0x00,0x00 ; <RIGHT> fcb 0x20,0x20,0x20,0x20,0x20,0x20,0x20,0x20 ; <SPACE> fcb 0x30,0x00,0x00,0x00,0x00,0x00,0x00,0x00 ; 0 (shift/ctrl variants shadowed above) fcb 0x31,0x21,0x00,0x00,0x00,0x00,0x00,0x00 ; 1 ! fcb 0x32,0x22,0x00,0x00,0x00,0x00,0x00,0x00 ; 2 " fcb 0x33,0x23,0x00,0x00,0x00,0x00,0x00,0x00 ; 3 # fcb 0x34,0x24,0x00,0x00,0x00,0x00,0x00,0x00 ; 4 $ fcb 0x35,0x25,0x00,0x00,0x00,0x00,0x00,0x00 ; 5 % fcb 0x36,0x26,0x00,0x00,0x00,0x00,0x00,0x00 ; 6 & fcb 0x37,0x27,0x00,0x00,0x00,0x00,0x00,0x00 ; 7 ' fcb 0x38,0x28,0x00,0x00,0x00,0x00,0x00,0x00 ; 8 ( fcb 0x39,0x29,0x00,0x00,0x00,0x00,0x00,0x00 ; 9 ) fcb 0x3a,0x2a,0x00,0x00,0x00,0x00,0x00,0x00 ; : * fcb 0x3b,0x2b,0x00,0x00,0x00,0x00,0x00,0x00 ; ; + fcb 0x2c,0x3c,0x00,0x00,0x00,0x00,0x00,0x00 ; , < fcb 0x2d,0x3d,0x00,0x00,0x00,0x00,0x00,0x00 ; - = fcb 0x2e,0x3e,0x00,0x00,0x00,0x00,0x00,0x00 ; . > fcb 0x2f,0x3f,0x00,0x00,0x00,0x00,0x00,0x00 ; / ? fcb 0x0d,0x0d,0x0d,0x0d,0x0d,0x0d,0x0d,0x0d ; <ENTER> fcb 0x0c,0x5c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c ; <CLEAR> fcb 0x03,0x03,0x1b,0x1b,0x9b,0xbb,0xdb,0xfb ; <BREAK> fcb 0x1c,0x1d,0x1c,0x1d,0x00,0x00,0x00,0x00 ; <F1> fcb 0x1e,0x1f,0x1e,0x1f,0x00,0x00,0x00,0x00 ; <F2> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Console screen output driver ; ; Clear screen console_clear ldb #0x60 ; VDG space character ldx #textscreen ; point to text screen stx console_curptr ; set cursor pointer to start of screen console_clear0 stb ,x+ ; blank a character cmpx #textscreen+0x200 ; end of screen? blo console_clear0 ; brif not rts ; Output NUL terminated string console_outstr0 bsr console_outchr ; output the character console_outstr lda ,x+ ; get byte from string bne console_outstr0 ; brif not end of string rts ; Output NUL terminated string followed by a newline console_outstrn bsr console_outstr ; output the string ; fallthrough intentional ; Output a newline (CR LF) console_outnl lda #0x0d ; do the CR bsr console_outchr lda #0x0a ; do the LF ; fallthrough intentional ; Output a single character to the screen; enter with character in A console_outchr pshs d,x ; save registers ldx console_curptr ; get current cursor pointer cmpa #0x20 ; printable character? blo console_outchr5 ; brif not tsta ; is it a graphics block? bmi console_outchr1 ; brif so - don't do anything to it cmpa #0x40 ; number or most non-alpha characters? blo console_outchr0 ; brif so - will need to flip bit 6 cmpa #0x60 ; upper case? blo console_outchr1 ; brif so - don't need to do anything to it anda #0xdf ; clear bit 5 of lower case; moves it to bottom of character set console_outchr0 eora #0x40 ; flip bit 6 - the "inversion" bit console_outchr1 sta ,x+ ; stick it on screen console_outchr2 stx console_curptr ; save new cursor pointer cmpx #textscreen+0x200 ; end of screen? blo console_outchr4 ; brif not leax -32,x ; move pointer back one line stx console_curptr ldx #textscreen ; point to start of screen console_outchr3 ldd 32,x ; get bytes from next line std ,x++ ; stick them here cmpx #textscreen+0x1e0 ; at last row? blo console_outchr3 ; brif not ldb #0x60 ; space character for VDG screen bsr console_clear0 ; blank out last row (borrowing screen clear loop) console_outchr4 puls d,x,pc ; restore registers and return console_outchr5 cmpa #0x0c ; form feed? bne console_outchr6 ; brif not bsr console_clear ; clear screen puls d,x,pc ; restore registers and return console_outchr6 cmpa #0x0d ; carriage return? bne console_outchr7 ; brif not ldb console_curptr+1 ; get current screen pointer LSB andb #0xe0 ; reset offset to start of line stb console_curptr+1 ; save new pointer LSB puls d,x,pc ; restore registers and return console_outchr7 cmpa #0x0a ; line feed? bne console_outchr8 ; brif not ldx console_curptr ; get cursor pointer leax 32,x ; move it forward exactly one line bra console_outchr2 ; go update stuff check for scroll console_outchr8 cmpa #0x08 ; backspace? bne console_outchr9 ; brif not cmpx #textscreen ; at start of screen? beq console_outchr4 ; brif so - backspace does nothing leax -1,x ; back up pointer (backspace is non-destructive) bra console_outchr2 ; go update pointers, etc. console_outchr9 cmpa #0x09 ; TAB character? bne console_outchr4 ; brif not ldb console_curptr ; get LSB of pointer andb #7 ; 8 space tabs - only keep low 3 bits lda #0x60 ; space character (tab is destructive) console_outchra sta ,x+ ; put a space out incb ; bump counter cmpb #8 ; at next tab stop? blo console_outchra ; brif not bra console_outchr2 ; go update details and check for scroll ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; General I/O handling package ; ; These routines operate on the I/O channel specified by filenum. The defined values of filenum are: ; ; 0: keyboard/screen console ; ; Read a line from the active file into linebuff. The resulting line will be NUL terminated leading to at most ; linbuffsize-1 character input. The trailing CR/LF will not be included. The input will be echoed if linebuffecho is ; enabled. Exit with the length of the input line in B. readline ldx #linebuff ; point to line input buffer clr ,x ; make sure buffer is NUL terminated readline0 bsr readchr ; read an input character bcs readline1 ; brif not EOF cmpa #0x0d ; CR (carriage return) beq readline1 ; brif so - return cmpa #0x03 ; BREAK? bne readline3 ; brif not coma ; set carry for irregular exit skip1 readline1 clra ; clear carry for regular exit pshs cc ; save carry state lda readlinenoecho ; are we echoing? bne readline2 ; brif not lda #0x0d ; echo carriage return + line feed bsr writechr readline2 tfr x,d ; get end address after input subd #linebuff ; subtract start of buffer; D is now length and C is clear clr ,x ; make sure line is NUL terminated puls cc,pc ; restore BREAK flag (C) and return readline3 cmpa #0x08 ; backspace? bne readline4 ; brif not cmpx #linebuff ; at start of buffer? beq readline0 ; brif so - do nothing leax -1,x ; move back buffer pointer bsr readlinee ; write a BS lda #0x20 ; write a space bsr readlinee lda #0x08 ; and finally a BS bsr readlinee bra readline0 ; go process more characters readline4 cmpa #0x0c ; form feed? bne readline5 ; brif not bsr readlinee ; go echo character if needed bra readline ; go restart line entry readline5 cmpa #0x20 ; is it non-printing? blo readline0 ; brif so - don't store it and continue bsr readlines ; stash character in buffer and echo if necessary bra readline0 ; go get another character readlines cmpx #linebuff+linebuffsize-1 ; is the line buffer full? bhs readlinee0 ; brif so - don't store character OR echo it sta ,x+ ; stash character readlinee ldb readlinenoecho ; are we echoing? bne readlinee0 ; brif not bsr writechr ; echo the character readlinee0 rts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Write a newline if not at left margin. This will unconditinally output a newline for devices where the horizontal ; position is not knowable. writecondnl lda filenum ; get file number bne writenl ; brif not screen - we'll do it unconditionally lda console_curptr+1 ; get LSB of cursor pointer anda #0x1f ; keep only the low 5 bits (32 characters per line) beq writecondnl0 ; brif no newline is needed ; fallthrough intended ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Write a newline to the chosen device. writenl lda #0x0d ; code for carriage return - will serve as newline ; fallthrough intended ; Write a character to the active file; all registers preserved but C will be set if the output file cannot handle ; an output character (doesn't exist, etc.) writechr tst filenum ; is it screen? beq writechr_scr ; brif writing to screen orcc #1 ; unknown device flag writecondnl0 rts ; Handle output to the screen. This is where we convert CR to CRLF writechr_scr jsr console_outchr ; output the character cmpa #0x0d ; was it CR? bne writechr_scr0 ; brif not lda #0x0a ; ouptut an LF jsr console_outchr lda #0x0d ; restore original value writechr_scr0 andcc #0xfe ; clear error flag rts ; Read a character from the active file and return it in A; in the event that EOF is detected, readeof will be nonzero ; and the call will return with carry set. readchr clr fileeof ; flag not end of file (and clear carry) lda filenum ; get input file number beq readchr_kb ; brif keyboard input com fileeof ; flag end of file (C set and fileeof nonzero) rts ; Read character from keyboard; blink cursor while doing so readchr_kb pshs b ; preserve B as temp storage ldb [console_curptr] ; get character at cursor inc console_blnkdel ; activate cursor blinking (first interrupt will cycle it) readchr_kb0 jsr keyb_getkey ; read keyboard bcc readchr_kb1 ; brif we got a result cwai #0xaf ; wait for interrupt to scan keyboard bra readchr_kb0 ; see if we have something yet readchr_kb1 clr console_blnkdel ; disable cursor blinking stb [console_curptr] ; restore screen character clrb ; clear carry to indicate not eof puls b,pc ; restore temp and return ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Write a character to the selected output device. If the device is one that does not support actual lower case, then ; conver the character to upper case. Otherwise, pass it through as is. Currently, only the console screen falls into ; this category. This *will* modify the character in A if a change is made. writechrconduc tst filenum ; is it screen? bne writechr ; brif not - just output it tst console_truelc ; does the current text screen support actual lower case? bne writechr ; brif so - just output character cmpa #'a ; is it lower case? blo writechr ; brif not cmpa #'z ; is it still lower case? bhi writechr ; brif not suba #0x20 ; shift to upper case bra writechr ; go output it ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Write a NUL terminated string at X to the screen. Conditionally convert to upper case based on the screen type. writestrconduc0 bsr writechrconduc ; output the character writestrconduc lda ,x+ ; fetch character from string bne writestrconduc0 ; brif not end of string rts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Fetch next input character, skip spaces. This is structured the way it is to avoid burning any register except A ; which is used for the returned value. Z will be set if the input character is NUL or a colon. C will be set if the ; input character is an ASCII digit. This allows testing Z to identify the end of a command due to either a colon or ; the end of a line. ; ; Compared to Color Basic, the instruction sequence only varies in the handling of the LDA. In Color Basic, the sequence ; is an LDA extended followed by a JMP extended. This totals to 9 cycles (5 for LDA, 4 for JMP). In LWBasic, an LDA ; with extended indirect addressing is used. This also totals 9 cycles. The only other difference is when a space is ; detected where the branch can be direct to the nextchar code instead of having to branch around a direct page JUMP ; which saves 3 cycles for the case where a space is detected. In other words, this is only slower by virtue of the ; fact that it is called with an extended JSR instead of a direct JSR which causes one extra cycle to be used there ; and one extra byte for each call to nextchar or curchar. ; ; On 6309, native move saves an extra cycle in the LDA sequence using the LDA extended followed by JMP extended ; sequence. ; ; This whole thing could be sped up by keeping the input pointer in a register. However, retaining the ability to ; use Y without having to save it first is likely more beneficial. nextchar inc inputptr+1 ; bump LSB of input pointer bne curchar ; brif no carry inc inputptr ; bump MSB curchar lda [inputptr] ; read the byte cmpa #'9+1 ; clear C if above ASCII digits, Z if colon bhs curchar0 ; brif above the ASCII digits cmpa #0x20 ; is it a space? beq nextchar ; brif so - skip over it suba #'0 ; clever way to set C if >= ASCII 0, Z if zero suba #-'0 curchar0 rts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; This is exactly the same as nextchar except it doesn't skip spaces. Unfortunately, for efficiency purposes, we need ; to actually duplicate code here. nextcharraw inc inputptr+1 ; bump LSB of input pointer bne curchar ; brif no carry inc inputptr ; bump MSB curcharraw lda [inputptr] ; fetch the byte cmpa #'9+1 ; clear C if above digits, set Z if colon bhs curcharraw0 ; brif above digits suba #'0 ; clever way to set C if >= ASCII 0, Z if zero suba #-'0 curcharraw0 rts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; The error handler ; ; Enter with the error number in B. This routine will do some cleanup and handle any ON ERROR GOTO handler that ; may be active. ; ; Note the error message lookup does not need to be efficient which is why the lookup just runs through the list ; of error messages in sequence looking for NUL terminators. The specific handling of B (error number) below avoids ; issues if there happen to be error codes above 128. ERROR clr filenum ; reset display device to console jsr writecondnl ; do a newline if needed (will preserve B) ldx #errormsg ; point to error message list incb ; account for decb below bra ERROR1 ; go search for correct message ERROR0 lda ,x+ ; end of message? bne ERROR0 ; brif not end of message ERROR1 decb ; at the correct one? bne ERROR0 ; brif not - skip to next one ERROR2 jsr writestrconduc ; output error message ldu curline ; are we in immediate mode? beq ERROR3 ; brif so ldx #inmsg ; point to " in " jsr writestrconduc ; output " in " ldd 2,u ; get line number jsr print_uint16d ; display the line number ERROR3 lds freetop ; reset the stack pointer (error routine could be called anywhere) clr ,-s ; reset the call stack sts stackptr ; fall through to immediate mode intentional ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Immediate mode handler immediate jsr writecondnl ; do newline if required ldx #prompt ; point to prompt string jsr console_outstrn immediate0 jsr readline ; read input line bcs immediate0 ; brif ended with BREAK ldx #linebuff ; point to start of line input buffer stx inputptr ; set input pointer jsr curchar ; skip spaces and set flags bcs immediate1 ; brif there's a line number tsta ; is there anything there at all (end of line)? beq immediate0 ; brif not - read another line ldx inputptr ; get the modified input pointer processing above jsr tokenize ; tokenize the line at inputptr, return with result at tokebuff and X jsr interpretline ; go interpret the tokenized line bra immediate ; go handle another line immediate1 bsr parse_lineno ; parse the line number bsr prog_findline ; go see if the line is in the program bne immediate3 ; brif not - no need to delete it ldu ,x ; get next line pointer which is where we start the copy from leay ,x ; use temp pointer for copying immediate2 lda ,u+ ; get source byte sta ,y+ ; stash it cmpu vartab ; did we reach the end of the program text? blo immediate2 ; brif not sty vartab ; save new end of program immediate3 jsr curchar ; skip any spaces after line number tsta ; is it the end of input (don't test for colon) beq immediate6 ; brif so - we don't need to insert a line pshs x ; save program insert location and line number ldx inputptr ; point to line text jsr tokenize ; tokenize line, get length to D leay ,x ; save tokenized line pointer addd #4 ; account for next line pointer and line number ldx vartab ; get start of copy location leau d,x ; set destination copy location D bytes further up stu vartab ; save new end of program immediate4 lda ,-x ; get byte from program sta ,-u ; stash it above the empty space cmpx ,s ; did we reach the insertion point? bne immediate4 ; brif not - keep going leas 2,s ; clear insertion location stu ,x++ ; set next line pointer to not null ldd binval ; set the line number for the program std ,x++ immediate5 lda ,y+ ; get byte from tokenized line sta ,x+ ; stash it in the program bne immediate5 ; brif not at end of tokenized line (see note for fixlineptrs) immediate6 bsr prog_fixlineptrs ; fix up line pointers (all of them) ldx vartab ; clear out variables stx objecttab stx freestart bra immediate0 ; go handle more input ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Fix up next line pointers. Enter at prog_fixlineptrs to do the entire program. Enter at prog_fixlineptrsx to start ; at the line pointered to by X, which MUST NOT point to the end of the program. ; ; Works by simply scanning for a NUL in the program text after a line header (pointer to next line and line number) ; and uses that as the new next line pointer. A NULL next line pointer flags the end of the program. ; ; Observation: if the program text format is changed such that it can include NULs embedded within a line, this routine ; will need to be updated to grok that. prog_fixlineptrs ldx progtext ; point to start of program prog_fixlineptrsx ldu ,x ; are we at the end of the program? beq prog_findline2 ; brif not (borrow RTS from findline) leau 4,x ; point to line text (past pointer and line number) prog_fixlineptrs1 lda ,u+ ; are we at the end of this line? bne prog_fixlineptrs1 ; brif not stu ,x ; set the next pointer for the previous line leax ,u ; move to the next line bra prog_fixlineptrsx ; go handle the next line ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Find a line in the program. Returns with C set and Z clear if no match and C clear and Z set if a match is found. X ; will point to either the exact matched line *or* the line that would be immediately after the desired line number if ; the line had been present, which could be the end of the program. D and U are clobbered. Enter at prog_findlinex to ; start searching at the line pointed to by X. Enter at prog_findline to start at the beginning of the program. Enter ; with the desired line number in binval. prog_findlinecl ldx curline ; get current line pointer beq prog_findline ; brif immediate mode ldd binval ; get desired line number cmpd 2,x ; is the desired line number >= current line? beq prog_findline2 ; brif this is the right line (optimizes goto self) bhi prog_findlinex ; brif desired line higher: start here instead of program start prog_findline ldx progtext ; point to start of program prog_findlinex ldu binval ; get line number to search for prog_findline0 ldd ,x ; end of program? beq prog_findline1 ; brif not cmpu 2,x ; does line number match? Z set if so, clear if not; C set not found bls prog_findline2 ldx ,x ; move to next line bra prog_findline0 ; see if we found the line yet prog_findline1 coma ; set carry for not found; also clears Z because D is zero from above prog_findline2 rts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Parse a line number and return it in binval; raise syntax error if the line number overflows 16 bits unsigned. ; Preserves; registers except D. This will accept the entire 16 bit unsigned number range which is why there is ; a BCS after every shift or add. Enter with the input pointer pointing to the number to parse. parse_lineno ldd zero ; clear out accumlator but preserve carry flag std binval jsr curchar ; set flags on current character; skip spaces bcc parse_lineno1 ; brif first character wasn't a digit - default to zero parse_lineno0 suba #0x30 ; adjust to binary digit pshs a ; save digit so we can add it later ldd binval ; get accumulated number lslb ; multiply accumulator by 10 rola ; times 2 bcs SNERROR ; brif overflow lslb rola ; times 4 bcs SNERROR ; brif overflow addd binval ; times 5 (add orignal value to times 4) bcs SNERROR ; brif overflow lslb rola ; times 10 bcs SNERROR ; brif overflow addb ,s+ ; add in accumulated digit adca #0 bcs SNERROR ; brif overflow std binval ; save accumulated number jsr nextcharraw ; get next input character; DO NOT skip spaces bcs parse_lineno0 ; brif it's also a digit parse_lineno1 rts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; The NEW command. ; ; This also includes several useful entry points: ; ; cmd_newraw: does the whole NEW but without any syntax checks ; cmd_newinptr: skips clearing the program text ; cmd_newvars: clears variables and resets the stack and other misc state ; cmd_newstack: just reset the stack and other misc state cmd_new bne parse_lineno1 ; brif there was an argument - don't wipe things out on syntax error cmd_newraw ldx progtext ; point to start of program clr -1,x ; make sure there's a NUL before the start of the program clr ,x+ ; put a NULL pointer at the start of the program clr ,x+ stx vartab ; set start of variables after that cmd_newinptr ldx progtext ;* set input pointer to the NUL before the program; this will cause the leax -1,x ;* the interpreter to drop to immediate mode no matter what it was stx inputptr ;* executing before this call if called from the main loop cmd_newvars ldx memsize ; get top of memory stx stringtab ; clear out string space ldx vartab ; get start of variables stx objecttab ; set start of large objects (arrays) there too (clear vars) stx freestart ; set start of free memory (end of large objects) (clear arrays) cmd_newstack ldx #stringstackend ; reset string stack (string stack counts down) stx stringstackptr ldx ,s ; get return address lds freetop ; reset stack to top of memory clr ,-s ; put a flag to stop stack searches (NEXT, RETURN) sts stackptr ; reset pointer for call stack clr contstmt ; clear "CONT" destination clr contstmt+1 jmp ,x ; return to caller ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Main interpretation loop ; ; Enter at interpret with inputptr pointing to the code stream to interpret. ; Enter at interpretline with X pointing to the command stream to interpret which will return to the caller one the ; command stream has completed. STOP or BREAK will return with carry set while END or falling off the end of the ; code will return with carry clear. In the event of an error, the usual error processing will be done and control ; will return to immediate mode with the stack reset. interpret jsr breakcheck ; check for BREAK bcs cmd_stop0 ; brif BREAK detected - go stop the program ldx inputptr ; get interpration address stx curstmt ; save address of the current statement (needed for some stuff) lda ,x+ ; are we at the end of the line? beq interpret0 ; brif so cmpa #': ; end of statement? beq interpret3 ; brif so - do a statement SNERROR ldb #err_sn ; raise a syntax error jmp ERROR interpret0 sta endflag ; flag the program exit state as "END" (will be zero) ldd curline ; were we in immediate mode? bne interpret1 ; brif not clra ; clear carry to indicate normal exit rts ; return to caller interpret1 ldd ,x ; are we at the end of the program? beq interpret4 ; brif so - bail out stx curline ; save pointer to current line leax 3,x ; set input pointer one before the start of the line text interpret2 stx inputptr interpret3 jsr nextchar ; fetch first character of next statement beq interpret ; brif end of statement - do the next statement dance tsta ; set flags properly for token lbpl cmd_let ; brif no command - do assignment (LET command is optional) ldx #primaryjump ; point to jump table anda #0x7f ; lose bit 7 leax a,x ; get half way to the correct offset ldx a,x ; get the address the other half of the way from here jsr nextchar ; skip past token and set flags jsr ,x ; call the routine bra interpret ; go handle the next statement dance interpret4 bsr cmd_stop1 ; make sure stack is aligned correctly (will not return) interpretline clr curline ; blank out current line pointer (for immediate mode) clr curline+1 leax -1,x ; move back before start of code stream bra interpret2 ; go interpret this statement and then continue with stuff ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Check for character in B and raise a syntax error if not found at current input pointer. If it is found, fetch the ; next input character. syncheckb cmpb [inputptr] ; do we have a syntax match? bne SNERROR ; brif not jmp nextchar ; return next input character ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; The END command. cmd_end bne SNERROR ; error out if there is an argument ;jsr closeall ; close all files for END clra ; flag END (clear carry) bra cmd_stop0 ; go do the stop/end cmd_stop bne SNERROR ; raise error if there was an argument coma ; flag STOP - set carry cmd_stop0 ror endflag ; set stop/end flag cmd_stop1 clr filenum ; reset I/O to console ldx curline ; in immediate mode? beq cmd_stop2 ; brif so - don't save the continue pointers stx contline ; save pointer to current line for CONT ldx curstmt ; get current statement address stx contstmt ; save it for CONT cmd_stop2 rol endflag ; get STOP/END to C (1=STOP) bcc cmd_stop3 ; brif END - don't do message ldx #breakmsg ; do "BREAK IN" jmp ERROR2 ; the bottom half of the error handler can deal with the details cmd_stop3 puls x,pc ; lose return address and return to caller of interpretation loop ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; REM and ' commands; also ELSE comes here since it needs to skip the rest of the line in that case. cmd_else cmd_apos cmd_rem clra ; clear carry ldx curline ; get start of current line beq cmd_stop3 ; brif immediate mode - fall back to caller ldx ,x ; get address of next line leax -1,x ; move back one stx inputptr ; put input pointer there rts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; DATA command ; ; need to skip to the end of the current statement, which is either the end of the line OR a colon not included inside ; a quoted string cmd_data ldx inputptr ; get input pointer cmd_data0 lda ,x+ ; get character at pointer beq cmd_data1 ; brif end of line cmpa #': ; end of statement? bne cmd_data2 ; brif not cmd_data1 leax -1,x ; move back to the NUL or colon stx inputptr ; reset input pointer for interpreter rts cmd_data2 cmpa #'" ; start of constant string? bne cmd_data0 ; brif not - process more characters cmd_data3 lda ,x+ ; get next string character beq cmd_data1 ; brif end of line cmpa #'" ; string delimiter? bne cmd_data3 ; brif not - keep going bra cmd_data0 ; process stuff outside string ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; RUN command cmd_run ;jsr closeall ; close all files jsr curchar ; what do we have as an argument? bcs cmd_goto ; brif a digit - it's a line number (RUN ###); do GOTO lbne SNERROR ; brif anything else on the line - not legit command ldx progtext ; point to start of program bra cmd_goto0 ; go transfer control to the start of the program ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; GOTO command cmd_goto jsr parse_lineno ; parse the line number cmd_gosub0 jsr prog_findlinecl ; go look up line number bcc cmd_goto0 ; brif line found ULERROR ldb #err_ul ; raise undefined line error jmp ERROR cmd_goto0 stx curline ; make sure we aren't flagging immediate mode leax -1,x ; move input pointer to NUL before destination line stx inputptr ; put input pointer there rts ; resume interpretation at the new location ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; GOSUB command cmd_gosub jsr parse_lineno ; parse the destination line so return location is after the line number ldd #tok_gosub*256+4 ; stack frame details bsr callstack_alloc ; make a stack frame ldx curline ; save current line pointer stx ,u ldx inputptr ; save current input pointer stx 2,u bra cmd_gosub0 ; go finish up as a GOTO ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; RETURN command ; POP command ; ; RETURN will search the call stack for the first GOSUB frame and remove all other placeholders it finds. A frame type ; of 0 will cause it to stop. cmd_pop skip1lda ; set nonzero for POP cmd_return clra ; set zero for RETURN pshs a ; save operation type bsr callstack_first ; get first entry on call stack bne cmd_return1 ; brif there's a frame - don't error RG_ERROR ldb #err_rg ; raise RETURN without GOSUB jmp ERROR cmd_return0 bsr callstack_next ; move to next entry beq RG_ERROR ; brif end of stack - raise error cmd_return1 cmpb #tok_gosub ; do we have a GOSUB frame? bne cmd_return0 ; brif not - try again lda ,s+ ; is it "POP"? bne cmd_return2 ; brif so - don't change flow control but clear stack frame ldx ,u ; get back saved line pointer stx curline ldx 2,u ; get back saved input pointer stx inputptr cmd_return2 bsr callstack_pop ; clean up call stack bra cmd_data ; move to end of statement (move past any "ON GOSUB" entries ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Point to the first entry on the call stack; yes this is trivial but it points to the payload, not the header. Also ; sets Z if there is nothing on the stack. callstack_first ldu stackptr ; get stack pointer ldb ,u++ ; set flags on frame type and adjust pointer rts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Move to the next frame on the call stack; enter with U pointing to a stack frame payload area callstack_next ldb -1,u ; get length of this frame leau b,u ; move to the next frame ldb -2,u ; set flags on frame type code rts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Create a stack frame. Enter with the frame type flag in A and the size in B. ; ; The stack frame of size B bytes plus 2 bytes for the length and type flag will be allocated between the actual ; hardware stack and the current call stack pointer. Return with the pointer to the allocated frame in U. As long as ; there are no pointers to anything on the hardware stack, this will allow the stack to be entirely intact after ; the call. callstack_alloc addb #2 ; account for the header bytes pshs a,b ; save the type and length negb ; need a negative offset leax ,s ; point to current bottom of stack leas b,s ; make a hole below the stack leau ,s ; get a pointer to the destination for copying callstack_alloc0 lda ,x+ ; copy a byte down sta ,u+ cmpx stackptr ; have we reached the top of the stack? blo callstack_alloc0 ; brif not stu stackptr ; save the new call stack pointer puls d ; get back the type and length values std ,u++ ; save type and length rts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Pop the call stack to the end of the frame pointed to by U; this will relocate the hardware stack to close the ; newly made gap in memory. callstack_pop leau -2,u ; move back to header ldb 1,u ; get length of frame leax b,u ; point to element after this frame sts ,--s ; save the current bottom of the stack stx stackptr ; save new call stack pointer callstack_pop0 lda ,-u ; copy a byte up sta ,-x cmpu ,s ; at the bottom of the call stack? bhi callstack_pop0 ; brif not leas 2,x ; reset the stack pointer (and lose the saved stack pointer value) rts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Miscelaneous strings prompt fcn 'OK' ; general prompt breakmsg fcn 'BREAK' ; "BREAK" message inmsg fcn ' in ' ; " in " message ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Print out an unsigned 16 bit value in D to the selected output stream print_uint16d pshs d,x,y,u ; save number and make some temporaries on the stack leay 2,s ; point to start of buffer ldu #10000 ; do the 10000s digit bsr print_uint16d4 ldu #1000 ; do the 1000s digit bsr print_uint16d4 ldu #100 ; do the 100s digit bsr print_uint16d4 ldu #10 ; do the 10s digit bsr print_uint16d4 puls d ; get back number residue and clean up stack addb #0x30 ; convert 1s digit to number stb ,y ; stash it clr 1,y ; NUL terminate it leay ,s ; point to start of converted number print_uint16d0 lda ,y ; get digit at start cmpa #0x30 ; zero digit? bne print_uint16d1 ; brif not - we can just show the number from here ldb 1,y ; end of number? beq print_uint16d1 ; brif so - show the zero anyway leay 1,y ; move past the zero bra print_uint16d0 ; see if we have more zeroes to skip print_uint16d1 lda ,y+ ; get number digit beq print_uint16d2 ; brif end of number jsr writechr ; output the digit bra print_uint16d1 ; handle next digit print_uint16d2 leas 6,s ; clean up the stack rts print_uint16d4 lda #0x30-1 ; init digit value pshs a,u ; save the digit position and digit value ldd 5,s ; get back residue print_uint16d5 inc ,s ; bump digit subd 1,s ; subtract out place value bcc print_uint16d5 ; brif we haven't got the right digit yet addd 1,s ; restore residue std 5,s ; save new residue puls a,u ; get back digit and place value off stack sta ,y+ ; save digit in buffer rts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; PRINT command cmd_print beq cmd_printeol ; brif no argument - do a newline cmd_print0 cmpa #'; ; semicolon? bne cmd_print1 ; brif not jsr nextchar ; skip the semicolon bne cmd_print0 ; brif not end of the statement rts cmd_print1 jsr eval_expr ; evaluate the expression ldb val0+val.type ; get value type cmpb #valtype_int ; integer? beq cmd_printint ; brif so - print integer lda #'! ; flag unknown expression type jsr console_outchr jsr console_outchr jsr console_outchr cmd_printnext jsr curchar ; see what we have here bra cmd_print ; and go process cmd_printeol jmp console_outnl ; do a newline and return cmd_printint leas -12,s ; make a buffer leay ,s ; point to buffer lda #0x20 ; default sign (positive) ldb val0+val.int ; is it negative? bpl cmd_printint0 ; brif not jsr val_negint32 ; negate the integer lda #'- ; negative sign cmd_printint0 sta ,y+ ; save sign ldu #cmd_printintpc ; point to positive constant table ldx #10 ; there are 10 constants to process ; subtraction loop - positive residue cmd_printint1 lda #'0-1 ; initialize digit sta ,y cmd_printint2 inc ,y ; bump digit ldd val0+val.int+2 ; subtract constant subd 2,u std val0+val.int+2 ldd val0+val.int sbcb 1,u sbca ,u std val0+val.int bcc cmd_printint2 ; brif we didn't go negative ldd val0+val.int+2 ; undo last subtract addd 2,u std val0+val.int+2 ldd val0+val.int adcb 1,u adca ,u std val0+val.int leay 1,y ; move to next digit in buffer leau 4,u ; move to next constant leax -1,x ; done all constants? bne cmd_printint1 ; brif not - done all cmd_printint5 clr ,y ; NUL terminate the string leax 1,s ; point past the sign cmd_printint6 lda ,x+ ; get digit beq cmd_printint8 ; brif end of number cmpa #'0 ; is it a zero? beq cmd_printint6 ; brif so - skip it cmd_printint7 lda ,s ; get the sign sta ,--x ; put it at the start of the number jsr console_outstr ; display the number leas 12,s ; clean up stack bra cmd_printnext ; go print the next thing cmd_printint8 leax -1,x ; restore one of the zeros bra cmd_printint7 ; go finish up cmd_printintpc fqb 1000000000 ; 10^9 fqb 100000000 ; 10^8 fqb 10000000 ; 10^7 fqb 1000000 ; 10^6 fqb 100000 ; 10^5 fqb 10000 ; 10^4 fqb 1000 ; 10^3 fqb 100 ; 10^2 fqb 10 ; 10^1 fqb 1 ; 10^0 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Error messages ; ; Each error begins with a deferr macro invocation which will define a symbol err_slug with the next error number ; ; deferr slug ; ; This is then followed by the error message defined with fcn. ; ; Real error numbers start at 1; 0 is used to indicate no error. *pragmapush list *pragma nolist __errnum set 0 deferr macro noexpand err_{1} equ __errnum __errnum set __errnum+1 endm *pragmapop list errormsg deferr none fcn 'No error' deferr nf fcn 'NEXT without FOR' deferr sn fcn 'Syntax error' deferr ul fcn 'Undefined line number' deferr rg fcn 'RETURN without GOSUB' deferr ov fcn 'Overflow' deferr tm fcn 'Type mismatch' ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; The LET command which is the default if no token begins a statement cmd_let jmp SNERROR ; not yet implemented ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Expression Evaluation Package ; ; This is the expression evaluator. It handles everything from parsing numbers to dispatching function calls. The main ; entry point is eval_expr which will evaluate an arbitrary expression. It returns as soon as it reaches something it ; doesn't understand as part of an expression. ; ; The special handling for relational operators is required because Basic allows them in all eval_expr clrb ; flag previous operator as minimum precdence (end of expression) eval_expraux jsr eval_term ; evaluate the first term of the expression eval_expr0 jsr curchar ; fetch current input beq eval_expr1 ; brif end of expression - we're done cmpa #tok_or ; is it above operators? bhi eval_expr1 ; brif so suba #tok_plus ; offset to zero for first operator token bcc eval_expr2 ; brif it is an operator eval_expr1 rts eval_expr2 pshs b ; save previous operator precedence ldx #oper_tab ; point to operator table tfr a,b ; shift to B for "ABX" abx ; add three times (3 bytes per entry) abx ; OBS: TFR + ABX + ABX + ABX is faster than LDB + MUL + ABX abx ; now X points to the operator entry in the table ldb ,x ; get precedence of current operation cmpb ,s ; is it higher than the current operation? bhi eval_expr3 ; brif so - process this operator puls b,pc ; return current value to complete previous operation eval_expr3 jsr nextchar ; eat the operator token ldx 1,x ; get handler address of this operator pshs x ; save handler address for later lda val0+val.type ; get current value type ldx val0 ; get value accumlator contents (6 bytes) ldy val0+2 ldu val0+4 pshs a,x,y,u ; save it on the stack jsr eval_expraux ; evaluate the following term and higher precedence expressions puls a,x,y,u ; get back saved value stx val1 ; save it to the second value accumulator sty val1+2 stu val1+4 sta val1+val.type ; save previous value type jsr [,s++] ; go handle the operator puls b ; get back the previous operator precedence bra eval_expr0 ; go process another operator or end of expression eval_term jsr curchar ; get current input character beq eval_term0 ; brif end of input - this is an error bcs eval_number ; brif digit - we have a number ; bmi eval_func ; brif we have a token - handle function call cmpa #'. ; decimal point? beq eval_number ; brif so - evaluate number cmpa #'- ; negative sign? beq eval_number ; brif so - evaluate number cmpa #'+ ; positive sign? beq eval_number ; brif so - evaluate number eval_term0 jmp SNERROR ; we have something unrecognized - raise error ; Evaluate a number constant. Currently this only handles 32 bit integers. eval_number ldb #valtype_int ; start with integer value stb val0+val.type ; set return value ldx zero ; blank out the value stx val0 stx val0+2 stx val0+4 bra eval_number1 ; go do the parsing eval_number0 jsr nextchar ; fetch next input beq eval_numberr ; brif end of expression - bail eval_number1 cmpa #'- ; negative (ascii sign)? beq eval_number3 ; brif so cmpa #tok_minus ; negative (operator negative)? bne eval_number2 ; brif not eval_number3 com val0+val.fpsign ; invert sign bra eval_number0 ; deal with next input eval_number2 cmpa #'+ ; unary +? beq eval_number0 ; brif so - skip it eval_number5 cmpa #'. ; decimal point? beq eval_float ; brif decimal - force float cmpa #'0 ; is it a number? blo eval_numberr ; brif below digit cmpa #'9 ; is it still a number? bhi eval_numberr ; brif above digit suba #'0 ; offset to binary digit value pshs a ; save digit value ldx val0+val.int ; get current value for later (for quick multiply by 10) ldd val0+val.int+2 pshs d,x ; stored with words swapped on stack for efficiency for later lsl val0+val.int+3 ; times 2 rol val0+val.int+2 rol val0+val.int+1 rol val0+val.int bcs OVERROR ; brif overflowed lsl val0+val.int+3 ; times 4 rol val0+val.int+2 rol val0+val.int+1 rol val0+val.int bcs OVERROR ; brif overflowed ldd val0+val.int+2 ; times 5 (add original value) addd ,s++ std val0+val.int+2 ldd val0+val.int adcb 1,s adca ,s++ std val0+val.int bcs OVERROR lsl val0+val.int+3 ; times 10 rol val0+val.int+2 rol val0+val.int+1 rol val0+val.int bcs OVERROR ; brif overflowed ldd val0+val.int+2 ; get low word addb ,s+ ; add in current digit adca #0 std val0+val.int+2 ldd val0+val.int adcb #0 adca #0 std val0+val.int bcs OVERROR ; brif overflowed bpl eval_number4 ; brif we haven't wrapped negative cmpd #0x8000 ; is it valid negative two's complement? bhi OVERROR ; brif not ldd val0+val.int+2 ; is it still valid two's complement (max negative)? bne OVERROR ; brif so eval_number4 jsr nextchar ; fetch next input character bra eval_number5 ; go handle it OVERROR ldb #err_ov ; flag overflow jmp ERROR eval_numberr ldb val0+val.fpsign ; is the number we want negative? beq eval_numberr0 ; brif not jsr val_negint32 ; negate the integer eval_numberr0 rts eval_float jmp SNERROR ; we don't handle floating point yet ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Operator table ; ; Each entry starts with the precedence value followed by the handler routine. Each handler will receive its left ; operand in val1 and its right operand in val0 and should return its result in val0. oper_tab fcb 0x79 ; addition fdb SNERROR fcb 0x79 ; subtraction fdb SNERROR fcb 0x7b ; multiplication fdb SNERROR fcb 0x7b ; division fdb SNERROR fcb 0x7f ; exponentiation fdb SNERROR fcb 0x64 ; less than fdb SNERROR fcb 0x64 ; equal to fdb SNERROR fcb 0x64 ; greater than fdb SNERROR fcb 0x64 ; less than or equal to fdb SNERROR fcb 0x64 ; greater than or equal to fdb SNERROR fcb 0x64 ; not equal to fdb SNERROR fcb 0x50 ; boolean AND fdb SNERROR fcb 0x46 ; boolean OR fdb SNERROR ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Set carry if upper/lower case alpha setcifalpha cmpa #'z+1 ; is it above lower case Z? bhs setcifalpha0 ; brif so, C clear suba #'a ; set C if >= lower case A suba #-'a bcs setcifalpha0 ; brif lower case alpha setcifualpha cmpa #'Z+1 ; is it above upper case Z? bhs setcifalpha0 ; brif so, C clear suba #'A ; set C if >= upper case A suba #-'A setcifalpha0 rts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Set carry if digit setcifdigit cmpa #'9+1 ; is it above digit 9? bhs setcifdigit0 ; brif so, C clear suba #'0 ; set C if >= digit 0 suba #-'0 setcifdigit0 rts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Arithmetic package ; ; This section contains routines that handle floating point and integer arithmetic. ; ; Most routines take a pointer to a value accumulator in X. Some take two pointers with the second in U. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Match operands for a numeric calculation. This works as follows: ; ; * If both operands are the same, ensure the type is numeric and return ; * If one operand is floating point, convert the other to floating point, as long as it is numeric ; * If one or both oeprands are not numeric, raise a type mismatch ; The operands are in (X) and (U) val_matchtypes ldb val.type,x ; get the type of first argument cmpb #valtype_int ; is it integer? beq val_matchtypes0 ; brif so cmpb #valtype_float ; is it floating point? beq val_matchtypes1 ; brif so TMERROR ldb #err_tm ; raise a type mismatch jmp ERROR val_matchtypes0 ldb val.type,u ; get type of second operand cmpb #valtype_int ; is it integer? bne val_matchtypes2 ; brif not val_matchtypes3 rts val_matchtypes2 cmpb #valtype_float ; is it floating point? bne TMERROR ; brif not - raise error pshs u ; save pointer to second operand bsr val_int32tofp ; convert first argument to floating point puls u,pc ; restore second operand pointer and return val_matchtypes1 ldb val.type,u ; get second argument type cmpb #valtype_float ; is it floating point? beq val_matchtypes3 ; brif so - we're good cmpb #valtype_int ; is it integer? bne TMERROR ; brif not - invalid type combination pshs x,u ; save value pointers leax ,u ; convert (U) to floating point bsr val_int32tofp puls x,u,pc ; restore argument pointers and return ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Negate the 32 bit integer (for fp mantissa) at (X) val_negint32 ldd zero ; subtract integer value from zero subd val.int+2,x std val.int+2,x ldd zero sbcb val.int+1,x sbca val.int,x std val.int,x rts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Convert integer value at (X) to floating point value at (X). Enter at val_uint32tofp to treat the 32 bit value as ; unsigned. Otherwise enter at val_int32tofp to treat it as signed. val_uint32tofp clr val.fpsign,x ; for positive sign bra val_int32tofpp ; go process as positive val_int32tofp ldb val.int,x ; get sign to A sex sta val.fpsign,x ; set sign of result bpl val_int32tofpp ; brif positive - don't need to do a two's complement adjustment bsr val_negint32 ; negate the integer value val_int32tofpp ldb valtype_float ; set result to floating point stb val.type,x ldb #0xa0 ; exponent to have binary point to the right of the mantissa stb val.fpexp,x ; set the exponent clrb ; clear out extra precision bits ; fall through to normalize the value at (X) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Normalize floating point value at (X); this will shift the mantissa until there is a one in the leftmost ; bit of the mantissa. The algorithm is as follows: ; ; 1. Shift the mantissa left until a 1 bit is found in the high bit of the mantissa. ; 1a. If more than 40 bits of left shifts occur, determine that the value is zero and return ; 2. Adjust exponent based on number of shifts ; 2a. If new exponent went below -127, then underflow occurred and zero out value ; 2b. If new exponent went above +127, raise an overflow ; 3. If bit 7 of the extra precision byte is clear, return the resulting value ; 4. Add one to the mantissa ; 5. If a carry in (4) occurred, then set high bit of mantissa and bump exponent ; 6. If new exponent carries, then raise overflow ; 7. Return result. ; ; Note that if we carried in (4), the only possible result is that the mantissa ; rolled over to all zeroes so there is no need to shift the entire mantissa right ; nor is there any reason to check for additional rounding. ; ; The above algorithm has some optimizations in the code sequence below. fp_normalize pshs b ; save extra bits clrb ; set shift counter/exponent adjustment fp_normalize0 lda val.fpmant,x ; set flags on high word of mantissa bne fp_normalize2 ; brif we don't have a full byte to shift addb #8 ; account for a while byte of shifts ldu val.fpmant+1,x ; shift mantissa left 8 bits stu val.fpmant,x lda val.fpmant+3,x sta val.fpmant+2,x lda ,s ; and include extra bits sta val.fpmant+3,x clr ,s ; and blank extra bits cmpb #40 ; have we shifted 40 bits? blo fp_normalize0 ; brif not - keep shifting bra fp_normalize7 ; go zero out the value fp_normalize1 incb ; account for one bit of shifting lsl ,s ; shift mantissa and extra bits left (will not be more than 7 shifts) rol val.fpmant+3,x rol val.fpmant+2,x rol val.fpmant+1,x rol val.fpmant,x fp_normalize2 bpl fp_normalize1 ; brif we have to do a bit shift pshs b ; apply exponent counter to exponent lda val.fpexp,x suba ,s+ bls fp_normalize6 ; brif we underflowed to zero bcc fp_normalize3 ; brif we did not overflow OVERROR2 jmp OVERROR ; raise overflow fp_normalize3 lsl ,s+ ; set C if the high bit of extra precision is set bcs fp_normalize5 ; brif bit set - we have to do rounding fp_normalize4 rts ; return if no rounding fp_normalize5 ldu val.fpmant+2,x ; add one to mantissa leau 1,u stu val.fpmant+2,x bne fp_normalize4 ; brif low word doesn't carry ldu val.fpmant,x leau 1,u stu val.fpmant,x bne fp_normalize4 ; brif high word doesn't carry ror val.fpmant,x ; shift right C in to high bit of mantissa (already set to get here) inc val.fpexp,x ; bump exponent for a right shift beq OVERROR2 ; brif it overflows (> +127) rts ; return result (only possible result was mantissa wrapped to zero) fp_normalize6 clr val.fpmant,x ; clear mantissa clr val.fpmant+1,x clr val.fpmant+2,x clr val.fpmant+3,x fp_normalize7 clr val.fpexp,x ; clear exponent and sign clr val.fpsign,x puls b,pc ; clean up stack and return ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Pack a floating point value at (X) fp_packval ldb val.fpsign,x ; get sign bmi fp_packval ; brif negative - the default 1 bit will do ldb val.fpmant,x ; clear high bit of mantissa for positive andb #0x7f stb val.fpmant,x fp_packval0 rts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Unpack a floating point value at (X) fp_unpackval0 ldb val.fpmant,x ; get high byte of mantissa sex ; now A is value for sign byte sta val.fpsign,x ; set sign orb #0x80 ; set high bit of mantissa stb val.fpmant,x rts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; The LIST command. ; ; Syntax: ; LIST ; LIST <line> ; LIST <line>- ; LIST -<line> ; LIST <start>-<end> cmd_list bne cmd_list1 ; brif we have arguments ldx progtext ; point to start of program cmd_list0 ldd #65535 ; set last line to list to max line number std binval bra cmd_list2 ; go do the listing cmd_list1 jsr parse_lineno ; parse starting line number (will default to 0) jsr prog_findline ; find the line or the one after where it would be jsr curchar ; are we at the end of the command? beq cmd_list2 ; brif so - we have a single line (binval will have the start line #) ldb #tok_minus ; insist on a - for a range if more than one line number jsr syncheckb beq cmd_list0 ; brif open ended ending - set to max line number jsr parse_lineno ; parse ending of range cmd_list2 ldd ,x ; are we at the end of the program? bne cmd_list4 ; brif not cmd_list3 rts cmd_list4 ldd 2,x ; get line number cmpd binval ; have we reached the end of the range? bhi cmd_list3 ; brif so - we're done jsr print_uint16d ; print out line number lda #0x20 ; and a space jsr writechr pshs x ; save start of this line (in case detokenizing exits early) leax 4,x ; move past line header bsr detokenize ; detokenize line to current output stream ldx [,s++] ; point to next line using saved pointer and clear it from the stack ; need to add a break check here bra cmd_list2 ; go handle another line ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Detokenize a line to the current output stream detokenize lda ,x+ ; get character from tokenized line bmi detokenize1 ; brif it's a keyword token lbeq writecondnl ; do a newline if needed and return cmpa #': ; is it a colon? bne detokenize0 ; brif not ldb ,x ; fetch subsequent character cmpb #tok_apos ; apostrophe version of REM? beq detokenize ; brif so - skip the colon cmpb #tok_else ; ELSE? beq detokenize ; brif so - skip the colon detokenize0 jsr writechr ; output it unmolested bra detokenize ; go handle another character detokenize1 ldu #primarydict ; point to primary dictionary table cmpa #0xff ; is it a secondary token? bne detokenize3 ; brif not ldu #secondarydict ; point to secondary dictionary table lda ,x+ ; get secondary token value bne detokenize3 ; brif not end of line leax -1,x ; don't consume the NUL detokenize2 lda #'! ; invalid token flag bra detokenize0 ; output it and continue detokenize3 anda #0x7f ; lose the high bit beq detokenize6 ; brif already at the right place detokenize4 ldb ,u ; end of dictionary table? beq detokenize2 ; brif so - show invalid tokenf lag detokenize5 ldb ,u+ ; fetch character in this keyboard bpl detokenize5 ; brif not end of keyword (high bit set) deca ; at the right token? bne detokenize4 ; brif not - skip another detokenize6 lda ,u+ ; get keyword character bmi detokenize7 ; brif end of keyword jsr writechr ; output it bra detokenize6 ; go fetch another detokenize7 anda #0x7f ; lose the high bit bra detokenize0 ; write it and move on with the input ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Canonicalize certain sequences; ALL the rewrite sequences must make the result shorter or keep it the same size makecanontab fcb tok_less,2 fcb tok_greater,tok_notequal fcb tok_equal,tok_lessequal fcb tok_greater,2 fcb tok_less,tok_notequal fcb tok_equal,tok_greaterequal fcb tok_equal,2 fcb tok_greater,tok_greaterequal fcb tok_less,tok_lessequal fcb 0 makecanon leay ,x ; point output to start of the buffer makecanon0 lda ,x+ ; get current byte sta ,y+ ; save in output bne makecanon1 ; brif not end of line rts makecanon1 bpl makecanon0 ; brif not a token cmpa #0xff ; is it secondary? bne makecanon2 ; brif not leax 1,x ; move past second half bra makecanon0 ; go handle next byte makecanon2 ldu #makecanontab ; point to replacement table makecanon3 cmpa ,u+ ; is it this entry? beq makecanon4 ; brif so ldb ,u+ ; get number of entries lslb ; 2 bytes per leau b,u ; move past entry ldb ,u ; end of table? bne makecanon3 ; brif not bra makecanon0 ; no substitutions found makecanon4 pshs x ; save original source pointer makecanon5 lda ,x+ ; get next character cmpa #0x20 ; is it space? beq makecanon5 ; brif so - skip it ldb ,u+ ; get number of replacement candidates makecanon6 cmpa ,u++ ; does it match? beq makecanon7 ; brif so decb ; seen all of them? bne makecanon6 ; brif not puls x ; restore input pointer bra makecanon0 ; go handle next input makecanon7 leas 2,s ; clear saved input pointer lda -1,u ; get replacement token sta -1,y ; put it in the output bra makecanon0 ; go handle more input ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Tokenize line to tokebuff ; ; Enter with X pointing to the text to tokenize. ; Exit with X pointing to the start of the tokenized line and D holding the length of the tokenized line. tokenize clr tok_skipkw ; clear "not token" flag clr tok_skipdt ; clear the "in data" flag ldy #tokebuff ; point to destination buffer pshs y ; set return value tokenize0 lda ,x+ ; get input character bne tokenize3 ; brif not end of input tokenize1 sta ,y+ ; blank out final byte in result tokenize2 ldx #tokebuff ; point to start of tokenized line bsr makecanon ; canonicalize certain sequences tfr y,d ; get end address to accumulator subd #tokebuff ; subtract out start; gives length of result puls x,pc ; set return pointer and return tokenize3 tst tok_skipkw ; are we in the middle of a "not token"? beq tokenize6 ; brif not jsr setcifalpha ; is it alpha bcs tokenize4 ; brif so - store it and continue jsr setcifdigit ; is it numeric? bcc tokenize5 ; brif not tokenize4 sta ,y+ ; save output character bra tokenize0 ; check for another tokenize5 clr tok_skipkw ; clear the "not token" flag tokenize6 cmpa #'" ; is it a string? bne tokenize8 ; brif not sta ,y+ ; save string delimiter tokenize7 lda ,x+ ; get input character beq tokenize1 ; brif end of input sta ,y+ ; save it in output cmpa #'" ; end of string? bne tokenize7 ; brif not bra tokenize0 ; brif tokenize8 cmpa #': ; end of statement? bne tokenize9 ; brif not clr tok_skipdt ; reset "in data" flag bra tokenize4 ; stash it and continue tokenize9 cmpa #0x20 ; is it a space? beq tokenize4 ; brif so - stash it unmodified tst tok_skipdt ; are we "in data"? bne tokenize4 ; brif so - don't tokenize it cmpa #'? ; PRINT shortcut? bne tokenize10 ; brif not lda #tok_print ; load token for PRINT bra tokenize4 ; move stash it and move on tokenize10 cmpa #'' ; ' shortcut for remark? bne tokenize12 ; brif not ldd #':*256+tok_apos ; put token for ' and an implied colon std ,y++ ; stash it tokenize11 lda ,x+ ; fetch byte from input sta ,y+ ; stash in output bne tokenize11 ; brif not end of input bra tokenize2 ; go finish up tokenize12 jsr setcifdigit ; is it a digit? bcs tokenize4 ; brif so - pass it through tsta ; is the high bit set? bmi tokenize0 ; ignore it if so ldu #primarydict ; point to keyword table leax -1,x ; back up input to start of potential token clr tok_kwtype ; set secondary table flag to primary table clr tok_kwmatch ; clear the matched token clr tok_kwmatch+1 clr tok_kwmatchl ; set length matched pshs x ; save start of input token tokenize13 clr tok_kwnum ; clear keyword number tokenize14 ldb ,u ; are we at the end of the table? bne tokenize16 ; brif not ldu #secondarydict ; point to secondary token dictionary com tok_kwtype ; flip to secondary token flag bne tokenize13 ; brif we haven't already done the secondaries puls x ; get back input pointer ldb tok_kwmatchl ; get length of best match beq tokenize15 ; brif we don't have a match abx ; move input pointer past matched token ldd tok_kwmatch ; get matched token number tsta ; is it a primary? beq tokenize24 ; brif so bra tokenize23 ; go stash two byte token tokenize15 com tok_skipkw ; set "not token flag" lda ,x+ ; get character bra tokenize4 ; stash it and continue tokenize16 ldx ,s ; get back start of input token clra ; initalize match length counter tokenize17 inca ; bump length counter ldb ,x+ ; get input character cmpb #'z ; is it above lower case Z? bhi tokenize18 ; brif so cmpb #'a ; is it below lower case A? blo tokenize18 ; brif so subb #0x20 ; convert to upper case tokenize18 subb ,u+ ; does it match? beq tokenize17 ; brif so - check another cmpb #0x80 ; did it match with high bit set? beq tokenize21 ; brif so - exact match leau -1,u ; back up to current test character tokenize19 ldb ,u+ ; end of token? bpl tokenize19 ; brif not tokenize20 inc tok_kwnum ; bump token counter bra tokenize14 ; go check another one tokenize21 cmpa tok_kwmatchl ; is it a longer match? bls tokenize20 ; brif not, ignore it sta tok_kwmatchl ; save new match length ldd tok_kwtype ; get the matched token count orb #0x80 ; set token flag std tok_kwmatch ; save matched token bra tokenize20 ; keep looking through the tables tokenize22 lda #': ; for putting implied colons in tokenize23 std ,y++ ; put output into buffer jmp tokenize0 ; go handle more input tokenize24 cmpb #tok_else ; is it ELSE? beq tokenize22 ; brif so - stash it with colon cmpb #tok_data ; is it DATA? bne tokenize26 ; brif not stb tok_skipdt ; set "in data" flag tokenize25 stb ,y+ ; stash token jmp tokenize0 ; go handle more tokenize26 cmpb #tok_rem ; is it REM? beq tokenize28 ; brif so cmpb #tok_apos ; apostrophe REM? bne tokenize25 ; brif not - stash token and continue lda #': ; stash the implied colon sta ,y+ bra tokenize28 tokenize27 ldb ,x+ ; fetch next input character tokenize28 stb ,y+ ; stash the character bne tokenize27 ; brif not end of input - do another jmp tokenize2 ; stash end of buffer and handle cleanup ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Special tokenization handling ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Keyword dictionaries and jump tables. These are defined by several macros which ensure that each command or function ; entry has an associated jump table entry. These macros are: ; ; defcmd string,symbase ; deffunc string,symbase,flags ; cmdtab ; functab ; cmdjump ; funcjump ; defcmd and deffunc will add an entry into the relevant dictionary table as well as adding one to the relevant jump ; tables. The cmdtab, functab, cmdjump, and funcjump will output the table definitions. *pragmapush list *pragma nolist __cmdnum set 0x80 __funcnum set 0x80 defcmd macro noexpand setstr __cmdtab="%(__cmdtab)\tfcs {1}\n" ifstr ne,"{3}","" setstr __cmdjump="%(__cmdjump)\tfdb {3}\n" else setstr __cmdjump="%(__cmdjump)\tfdb cmd_{2}\n" endc tok_{2} equ __cmdnum __cmdnum set __cmdnum+1 endm deffunc macro noexpand setstr __functab="%(__functab)\tfcs {1}\n" ifstr ne,"{4}","" setstr __funcjump="%(__funcjump)\tfcb {3}\n\tfdb {4}\n" else setstr __funcjump="%(__funcjump)\tfcb {3}\n\tfdb func_{2}\n" endc tok_{2} equ __funcnum __funcnum set __funcnum+1 endm cmdtab macro *pragmapush list *pragma nolist includestr "%(__cmdtab)" *pragmapop list fcb 0 ; flag end of table endm functab macro *pragmapush list *pragma nolist includestr "%(__functab)" *pragmapop list fcb 0 ; flag end of table endm cmdjump macro *pragmapush nolist *pragma nolist includestr "%(__cmdjump)" *pragmapop list endm funcjump macro *pragmapush nolist *pragma nolist includestr "%(__funcjump)" *pragmapop list endm *pragmapop list defcmd 'REM',rem defcmd /'/,apos defcmd 'DATA',data defcmd 'ELSE',else defcmd 'END',end defcmd 'STOP',stop defcmd 'LET',let defcmd 'NEW',new defcmd 'PRINT',print defcmd 'LIST',list defcmd 'RUN',run defcmd 'GOTO',goto defcmd 'GOSUB',gosub defcmd 'RETURN',return defcmd 'POP',pop defcmd '+',plus,SNERROR ; IMPORTANT: the operators from + to OR MUST stay in this exact sequence defcmd '-',minus,SNERROR ; with no gaps because a secondary lookup table is used for operator defcmd '*',times,SNERROR ; handling during binary operator handling. defcmd '/',divide,SNERROR defcmd '^',power,SNERROR defcmd '<',less,SNERROR defcmd '>',greater,SNERROR defcmd '=',equal,SNERROR defcmd '<=',lessequal,SNERROR defcmd '>=',greaterequal,SNERROR defcmd '<>',notequal,SNERROR defcmd 'AND',and,SNERROR defcmd 'OR',or,SNERROR defcmd 'NOT',not,SNERROR primarydict cmdtab secondarydict functab primaryjump cmdjump secondaryjump funcjump ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Need to ensure the vectors are at 0xbff2 zmb 0xbff2-* ; pad ROM up to the vector point fdb SW3VEC ; SWI3 vector fdb SW2VEC ; SWI2 vector fdb FRQVEC ; FIRQ vector fdb IRQVEC ; IRQ vector fdb SWIVEC ; SWI vector fdb NMIVEC ; NMI vector fdb START ; RESET vector (ROM entry point) endc ifdef COCO3 zmb 0xfff2-* ; pad ROM to bottom of vectors fdb INT.SWI3 ; SWI3 vector fdb INT.SWI2 ; SWI2 vector fdb INT.FIRQ ; FIRQ vector fdb INT.IRQ ; IRQ vector fdb INT.SWI ; SWI vector fdb INT.NMI ; NMI vector fdb START ; RESET vector (ROM entry point) else zmb 0x10000-* ; pad ROM to full size endc