; Copyright 2021 Piotr Meyer ; ; Permission to use, copy, modify, and/or distribute this ; software for any purpose with or without fee is hereby ; granted, provided that the above copyright notice and ; this permission notice appear in all copies. ; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ; ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL ; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO ; EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, ; INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES ; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, ; WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER ; TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE ; USE OR PERFORMANCE OF THIS SOFTWARE. .cpu "65816" .include "macros_inc.asm" ;---------------------------------------------------------- ; # Description ; ; RETRO/816 - a port of RETRO Forth to C256 Foenix ; RETRO Forth was created by Charles Childers (crc) ; see: http://retroforth.org/ ; ; Program is created for C256 Foenix computer but should be ; able to run on almost any compatible system. ; ; At this moment we provide single NGA machine with fixed ; addresses at ZP and in main memory, but there is a room ; for multiple, independent VMs ; ## porting ; ; Current version is designed to be run on C256 Foenix ; computer with Foenix Kernel loaded ; We need two functions to be supported: ; C256_GETCHW - "wait for char and return it in A" ; C256_PUTC - "print char from A to screen" ; ; ## memory layout in C256 ; ; $0040 - begin of shared regions, used by various routines ; $00E0 - end of shared regions ; $00F0 - 16 bytes of 'temporary user variables; ; ; $2000 - begin of free space (test code in Foenix) ; $7FFF - end of free space ; $8000 - begin of CPU stack ; $FEFF - end of CPU stack ; ; XXX - move it to ZP ; $01:0000 - beginning NGA (memory), single segment (64k) ; 0000 - begin of data stack ; 03ff - end of data stack ; 0400 - beign of return ; 07ff - end of return stack ; .... - unused ; $02:0000 - start of main NGA memory ; $05:FFFF - end of main NGA memory ; ; $3a:0000 - beginning of NGA code (overwrites BASIC) ; .. ; ; ## implementation-specific notes ; ; There are few shortcuts and many inefficiences in code, ; it should be corrected or extend in future releases ; ; At this moment main pointers are somewhat inconsistent ; - IP counts CELLS when SP i RP count BYTES. It simplify ; code a lot ; ; IP - 16bit instruction pointer, thats means that ; system is able to use only FFFF cells ; unit: CELLS ; ; IPPTR - 24bit in-memory pointer, allows to use ; 4*FFFF memory. It should be equal to IP << 2 ; unit: BYTES ; ; SP - 16bit, stack pointer ; unit: BYTES (inc/dec by 4 bytes) ; ; RP - 16bit, return addres stack pointer, ; unit: BYTES (inc/dec by 4 bytes) ; ; ## booting ; ; C256 boot process, as remainder: ; ; 1. after boot CPU PC gets addr from $FFFC, ; 2. that value points to $FF00 and following code ; CLC ; XCE ; JML $1000 - BOOT vector of Foenix Kernel ; 3. JML IBOOT - internal boot routine ; 4. ... and, finally JML $03:A0000 to init BASIC ;---------------------------------------------------------- ; # constants ; ; note - unlike in 65c816 stacks in original NGA grows up, STACK_DEPTH = $0400 ; bytes: depth of data stack ADDRESSES = $0400 ; bytes: depth of address stack IMAGE_ADDR = $02_0000 ; bytes: base address in real memory CELL_MAX = $FFFF ; max allowed cell, IP is word-sized IMAGE_BANKS = 4 ; by 64k, max with word-sized IP CELL_SIZE = 4 ; bytes: single CELL size ; some sanitization checks .cerror IMAGE_ADDR & $00FFFF != $0000, "IMAGE_ADDR should be bank-aligned!" ; TOS*, NOS*, TRS* and MEM* variant are accessed by indexed ; modes (,X and ,Y). Different base addresses (+0, +2) are ; used to access low and high words without extra inx/iny DSTACK = $0000 ; data stack addr, grows up NOSl = DSTACK ; second item (,X) NOSh = DSTACK + 2 ; second item (,X) TOSl = DSTACK + 4 ; current item, low word TOSh = DSTACK + 6 ; current item, high word RSTACK = $0400 ; return stack addr, grows up TRSl = RSTACK ; current stack item, low word TRSh = RSTACK + 2 ; current stack item. high word ; XXX - only used for stacks, rip it off MEM_SEGMENT = $01 ; memory bank segment: $01:xxxx ; nymber of devices supported by system NUM_DEVICES = 2 ; ## debug variables (only for go65c816 emulator) TRACE_ON = $10 TRACE_OFF = $11 KILL = $20 ; ## FMX kernel vectors C256_GETCHW = $104c ; get character (wait) C256_PUTC = $1018 ; put character ; --------------------------------------------------------- ; # local variables ; * = $60 IP .word 0 ; instruction pointer - cells IPPTR .dword 0 ; instruction pointer - bytes SP .word 0 ; data stack pointer - bytes RP .word 0 ; return stack pointer - bytes CMD .dword 0 ; temporary for OP unboundling TMP .dword 0 ; temporary TMPa = TMP ; additional identifiers TMPb .dword 0 ; for various cases TMPc .word 0 ; at this moment inst_di TMPd .word 0 ; ... ; --------------------------------------------------------- ; # main routine ; * = $03A0000 main clc xce main0 .setaxl .sdb `msg_banner ldx #<>msg_banner jsr prints jsr prepare_vm jsr execute .sdb `msg_end ldx #<>msg_end jsr prints jsl C256_GETCHW jml $1000 ; BOOT ; ## preparing environment ; ; 1. clear memory region ; 2. clear stacks ; 3. copy image to memory region ; prepare_vm ; 1. clear memory .sdb `msg_mclean ldx #<>msg_mclean jsr prints .setas .setxl lda #`IMAGE_ADDR sta TMP ldy #IMAGE_BANKS mclean0 lda TMP pha plb ldx #$0000 mclean1 stz $0,b,x inx bne mclean1 inc TMP dey bne mclean0 ; 2. clear stacks .sdb `msg_sclean ldx #<>msg_sclean jsr prints .sdb MEM_SEGMENT .setal ldx #STACK_DEPTH-2 prep0 stz #DSTACK,b,x dex dex bpl prep0 ldx #ADDRESSES-2 prep1 stz #RSTACK,b,x dex dex bpl prep1 ; 4. copy image .sdb `msg_copy ldx #<>msg_copy jsr prints .setas ldy #IMAGE_SIZE ldx #0 .databank ? copy0 lda IMAGE_SRC,x sta IMAGE_ADDR,x inx dey bne copy0 ; 4. set DBR to stack area .sdb MEM_SEGMENT ; XXX fix it rts ; ## main execute loop execute .setaxl lda #CELL_SIZE sta RP stz SP stz IP jsr update_ipptr execute0 jsr process_bundle wdm #4 ; debugging - op count lda RP beq quit jsr next_ipptr inc IP lda IP cmp #CELL_MAX ; NGA exit condition bcc execute0 quit rts ; ### process 4 commands in bundle process_bundle ldy #2 lda [IPPTR],y ; 7 cycles sta CMD+2 lda [IPPTR] ; also 7 cycles sta CMD and #$ff beq + ; skip .. (nop) asl a tax jsr (#<>op_table,k,x) + lda CMD+1 and #$ff beq + ; skip .. (nop) asl a tax jsr (#<>op_table,k,x) + lda CMD+2 and #$ff beq + ; skip .. (nop) asl a tax jsr (#<>op_table,k,x) + lda CMD+3 and #$ff beq + ; bne/rts for -1 cycle asl a tax jsr (#<>op_table,k,x) + rts op_table .addr inst_no .addr inst_li .addr inst_du .addr inst_dr .addr inst_sw .addr inst_pu .addr inst_po .addr inst_ju .addr inst_ca .addr inst_cc .addr inst_re .addr inst_eq .addr inst_ne .addr inst_lt .addr inst_gt .addr inst_fe .addr inst_st .addr inst_ad .addr inst_su .addr inst_mu .addr inst_di .addr inst_an .addr inst_or .addr inst_xo .addr inst_sh .addr inst_zr .addr inst_ha .addr inst_ie .addr inst_iq .addr inst_ii ;---------------------------------------------------------- ; ## tooling routines ; ### updates IPPTR (in bytes) from IP field (in cells) update_ipptr lda IP sta IPPTR stz IPPTR+2 asl IPPTR ; IPPTR = IP*4 rol IPPTR+2 asl IPPTR rol IPPTR+2 clc ; add base lda IPPTR+2 adc #`IMAGE_ADDR sta IPPTR+2 rts ; ### increases in-memory IPPTR pointer by CELL_SIZE next_ipptr lda IPPTR clc adc #CELL_SIZE sta IPPTR bcs + rts + inc IPPTR+2 rts ; ### print 0-terminated strings ; DBR - string segment ; X - string address prints .proc php .setas .setxl prints0 lda $0,b,x beq prints_done jsl C256_PUTC inx bra prints0 prints_done plp rts .pend ;---------------------------------------------------------- ; # NGA VM ; ; Implementation of nga VM, based on `vm/nga-c/nga.c` code. ; Current version may be suboptimal, but the goal is in most ; accurate implementation. ; .al .xl ; --------------------------------------------------------- ; ## .. ( 0) stack: - | - nop inst_no rts ; --------------------------------------------------------- ; ## li ( 1) stack: -n | - lit ; ; void inst_li() { ; sp++; ; ip++; ; TOS = memory[ip]; ; } inst_li lda SP ; 4 cycles clc ; 1 cycle adc #CELL_SIZE ; 3 cycles sta SP ; 4 cycles tax ; 2 cycles inc IP jsr next_ipptr lda [IPPTR] sta #TOSl,b,x ldy #2 lda [IPPTR],y sta #TOSh,b,x ; lda IP ; 4 cycles ; clc ; 1 cycle ; adc #4 ; 3 cycles ; sta IP ; 4 cycles ; tay ; 2 cycles ; lda #MEMl,b,y ; sta #TOSl,b,x ; lda #MEMh,b,y ; sta #TOSh,b,x rts ; --------------------------------------------------------- ; ## du ( 2) stack: n-nn | - dup ; ; void inst_du() { ; sp++; ; data[sp] = NOS; // it means TOS = NOS? ; } inst_du lda SP ; 4 cycles clc ; 1 cycle adc #CELL_SIZE ; 3 cycles sta SP ; 4 cycles tax ; 2 cycles lda #NOSl,b,x sta #TOSl,b,x lda #NOSh,b,x sta #TOSh,b,x rts ; --------------------------------------------------------- ; ## dr ( 3) stack: n- | - drop ; ; void inst_dr() { ; data[sp] = 0; // it means TOS=0? ; if (--sp < 0) ; ip = CELL_MAX; ; } inst_dr ldx SP stz #TOSl,b,x stz #TOSh,b,x txa sec sbc #4 sta SP bmi inst_dr0 rts ; IP+1 in exec loop == LIMIT == EXIT inst_dr0 lda #CELL_MAX-1 sta IP rts ; --------------------------------------------------------- ; ## sw ( 4) stack: xy-xy | - swap ; ; void inst_dr() { ; data[sp] = 0; // it means TOS=0? ; if (--sp < 0) ; ip = CELL_MAX; ; } inst_sw ldx SP ldy #TOSl,b,x ; TOS -> TMP lda #NOSl,b,x sta #TOSl,b,x ; NOS -> TOS tya sta #NOSl,b,x ; TMP -> NOS ldy #TOSh,b,x ; TOS -> TMP lda #NOSh,b,x sta #TOSh,b,x ; NOS -> TOS tya sta #NOSh,b,x ; TMP -> NOS rts ; --------------------------------------------------------- ; ## pu ( 5) stack: n- | -n push ; ; void inst_pu() { ; rp++; ; TORS = TOS; ; inst_dr(); ; } inst_pu lda RP ; 4 cycles clc ; 1 cycle adc #CELL_SIZE ; 3 cycles sta RP ; 4 cycles tay ; 2 cycles ldx SP lda #TOSl,b,x sta #TRSl,b,y lda #TOSh,b,x sta #TRSh,b,y jmp inst_dr ; --------------------------------------------------------- ; ## po ( 6) stack: -n | n- pop ; ; void inst_po() { ; sp++; ; TOS = TORS; ; rp--; ; } inst_po lda SP clc adc #CELL_SIZE sta SP tax ldy RP lda #TRSl,b,y sta #TOSl,b,x lda #TRSh,b,y sta #TOSh,b,x tya sec sbc #4 sta RP rts ; --------------------------------------------------------- ; ## ju ( 7) stack: a- | - jump ; ; void inst_ju() { ; ip = TOS - 1; // I'm not sure about that '-1' ; inst_dr(); ; } ; PROBLEM THERE - SP is 16-bit and argument to JUMP may ; be 32bit XXX - check it in already created image ; BUT - current image < 64k, so there shouldn't be problems inst_ju ldx SP lda #TOSl,b,x dec a sta IP jsr update_ipptr jmp inst_dr ; --------------------------------------------------------- ; ## ca ( 8) stack: a- | -A call ; ; void inst_ca() { ; rp++; ; TORS = ip; ; ip = TOS - 1; ; inst_dr(); ; } inst_ca lda RP clc adc #CELL_SIZE sta RP tay lda IP sta #TRSl,b,y ; for completness sake ldx SP lda #TOSl,b,x dec a sta IP jsr update_ipptr jmp inst_dr ; --------------------------------------------------------- ; ## cc ( 9) stack: af- | -A conditional call ; ; void inst_cc() { ; CELL a, b; ; a = TOS; inst_dr(); /* Target */ ; b = TOS; inst_dr(); /* Flag */ ; if (b != 0) { ; rp++; ; TORS = ip; ; ip = a - 1; ; } ; } inst_cc ldx SP ; a lda #TOSl,b,x sta TMP jsr inst_dr ldx SP lda #TOSl,b,x bne inst_cc_jmp lda #TOSh,b,x bne inst_cc_jmp jmp inst_dr inst_cc_jmp jsr inst_dr ; for compatibility lda RP clc adc #CELL_SIZE sta RP tay lda IP sta #TRSl,b,y lda #$0 sta #TRSh,b,y ; only lower.. lda TMP dec a sta IP jsr update_ipptr rts ;jmp inst_dr ; --------------------------------------------------------- ; ## re (10) stack: - | A- return ; ; void inst_re() { ; ip = TORS; ; rp--; ; } inst_re ldy RP lda #TRSl,b,y sta IP jsr update_ipptr tya sec sbc #4 sta RP rts ; --------------------------------------------------------- ; ## eq (11) stack: xy-f | - equality ; ; void inst_eq() { ; NOS = (NOS == TOS) ? -1 : 0; ; inst_dr(); ; } inst_eq ldx SP lda #NOSl,b,x cmp #TOSl,b,x bne inst_eq_no lda #NOSh,b,x cmp #TOSh,b,x bne inst_eq_no lda #<>-1 sta #NOSl,b,x lda #>`-1 sta #NOSh,b,x jmp inst_dr inst_eq_no stz #NOSl,b,x stz #NOSh,b,x jmp inst_dr ; --------------------------------------------------------- ; ## ne (12) stack: xy-f | - inequality ; ; void inst_eq() { ; NOS = (NOS != TOS) ? -1 : 0; ; inst_dr(); ; } inst_ne ldx SP lda #NOSl,b,x cmp #TOSl,b,x bne inst_ne_no lda #NOSh,b,x cmp #TOSh,b,x bne inst_ne_no stz #NOSl,b,x stz #NOSh,b,x jmp inst_dr inst_ne_no lda #<>-1 sta #NOSl,b,x lda #>`-1 sta #NOSh,b,x jmp inst_dr ; --------------------------------------------------------- ; ## lt (13) stack: xy-f | - less than ; ; void inst_eq() { ; NOS = (NOS < TOS) ? -1 : 0; ; inst_dr(); ; } ; it should be a signed comparison then ; http://www.6502.org/tutorials/compare_beyond.html#5 inst_lt ldx SP lda #NOSl,b,x cmp #TOSl,b,x lda #NOSh,b,x sbc #TOSh,b,x bvc inst_lt0 ; N eor V eor #$80 inst_lt0 bmi inst_lt_lt stz #NOSl,b,x stz #NOSh,b,x jmp inst_dr inst_lt_lt lda #<>-1 sta #NOSl,b,x lda #>`-1 sta #NOSh,b,x jmp inst_dr ; --------------------------------------------------------- ; ## gt (14) stack: xy-f | - greater than ; ; void inst_eq() { ; NOS = (NOS > TOS) ? -1 : 0; ; inst_dr(); ; } ; it should be a signed comparison then ; http://www.6502.org/tutorials/compare_beyond.html#5 inst_gt ldx SP lda #TOSl,b,x cmp #NOSl,b,x lda #TOSh,b,x sbc #NOSh,b,x bvc inst_gt0 ; N eor V eor #$80 inst_gt0 bmi inst_gt_gt stz #NOSl,b,x stz #NOSh,b,x jmp inst_dr inst_gt_gt lda #<>-1 sta #NOSl,b,x lda #>`-1 sta #NOSh,b,x jmp inst_dr ; --------------------------------------------------------- ; ## fe (15) stack: a-n | - fetch ; ; void inst_fe() { ; #ifndef NOCHECKS ; if (TOS >= CELL_MAX || TOS < -5) { ; ip = CELL_MAX; ; printf("\nERROR (nga/inst_fe): Fetch beyond valid memory range\n"); ; exit(1); ; } else { ; #endif ; switch (TOS) { ; case -1: TOS = sp - 1; break; ; case -2: TOS = rp; break; ; case -3: TOS = CELL_MAX; break; ; case -4: TOS = CELL_MIN_VAL; break; ; case -5: TOS = CELL_MAX_VAL; break; ; default: TOS = memory[TOS]; break; ; } ; #ifndef NOCHECKS ; } ; #endif ; } ; XXX - there no checks now, as we don't have a way ; to report them ; inst_fe ldx SP lda #TOSh,b,x bmi inst_fe0 ; special values lda #TOSl,b,x ; only 16 bit sta TMP stz TMP+2 asl TMP ; IPPTR = IP*4 rol TMP+2 asl TMP rol TMP+2 clc ; add base lda TMP+2 adc #`IMAGE_ADDR sta TMP+2 lda TMP lda [TMP] sta #TOSl,b,x ldy #2 lda [TMP],y sta #TOSh,b,x rts inst_fe0 lda #TOSl,b,x inc a ; it was -1? bne inst_fe1 ; no lda SP ; "TOS = sp-1" dec a lsr a ; SP in bytes lsr a ; stack uses cells sta #TOSl,b,x stz #TOSh,b,x rts inst_fe1 inc a ; it was -2? bne inst_fe2 lda RP ; "TOS = rp" lsr a lsr a sta #TOSl,b,x stz #TOSh,b,x rts inst_fe2 inc a ; it was -3? bne inst_fe3 lda #CELL_MAX ; "TOS = CELL_MAX" sta #TOSl,b,x stz #TOSh,b,x ; XXX - we uses max 64k rts inst_fe3 inc a ; it was -4? bne inst_fe4 lda #$0000 ; "TOS = CELL_MIN_VAL" sta #TOSl,b,x lda #$8000 ; XXX - check it sta #TOSh,b,x rts inst_fe4 inc a ; it was -5? bne inst_bad lda #$ffff ; "TOS = CELL_MAX_VAL" sta #TOSl,b,x lda #$7fff ; XXX - check it sta #TOSh,b,x rts inst_bad ; XXX - message to interpreter .sdb `err_memuf ldx #<>err_memuf jsr prints .setaxl lda #CELL_MAX-1 sta IP rts ; --------------------------------------------------------- ; ## st (16) stack: na- | - store ; ; void inst_st() { ; #ifndef NOCHECKS ; if (TOS <= CELL_MAX && TOS >= 0) { ; #endif ; memory[TOS] = NOS; ; inst_dr(); ; inst_dr(); ; #ifndef NOCHECKS ; } else { ; ip = CELL_MAX; ; printf("\nERROR (nga/inst_st): Store beyond valid memory range\n"); ; exit(1); ; } ; #endif ; } ; XXX - no checks now inst_st ldx SP lda #TOSl,b,x ; XXX only low word in use sta TMP stz TMP+2 asl TMP ; IPPTR = IP*4 rol TMP+2 asl TMP rol TMP+2 clc ; add base lda TMP+2 adc #`IMAGE_ADDR sta TMP+2 lda #NOSl,b,x sta [TMP] ldy #2 lda #NOSh,b,x sta [TMP],y jsr inst_dr jmp inst_dr ; --------------------------------------------------------- ; ## ad (17) stack: xy-n | - addition ; ; void inst_ad() { ; NOS += TOS; ; inst_dr(); ; } inst_ad ldx SP clc lda #NOSl,b,x adc #TOSl,b,x sta #NOSl,b,x lda #NOSh,b,x adc #TOSh,b,x sta #NOSh,b,x jmp inst_dr ; --------------------------------------------------------- ; ## su (18) stack: xy-n | - subtraction ; ; void inst_su() { ; NOS -= TOS; ; inst_dr(); ; } inst_su ldx SP sec lda #NOSl,b,x sbc #TOSl,b,x sta #NOSl,b,x lda #NOSh,b,x sbc #TOSh,b,x sta #NOSh,b,x jmp inst_dr ; --------------------------------------------------------- ; ## mu (19) stack: xy-n | - multiplication ; ; void inst_mu() { ; NOS *= TOS; ; inst_dr(); ; } ; taken almost verbatim from of816 forth: ; 32-bit unsigned multiplication with 64-bit result ; right-shifting version by dclxvi N = TMP inst_mu ldx SP ; only for 1:1 with original nga lda #TOSh,b,x pha lda #TOSl,b,x pha ; end lda N+2 pha lda N pha lda #$00 sta N ldy #32 lsr #TOSh,b,x ; STACKBASE+6,x ror #TOSl,b,x ; STACKBASE+4,x l1: bcc l2 clc sta N+2 lda N adc #NOSl,b,x ; STACKBASE+0,x sta N lda N+2 adc #NOSh,b,x ; STACKBASE+2,x l2: ror a ror N ror #TOSh,b,x ; STACKBASE+6,x ror #TOSl,b,x ; STACKBASE+4,x dey bne l1 sta #NOSh,b,x ; STACKBASE+2,x lda N sta #NOSl,b,x ; STACKBASE+0,x pla sta N pla sta N+2 ; only for 1:1 with original nga - XXX - fix it lda #TOSl,b,x sta #NOSl,b,x lda #TOSh,b,x sta #NOSh,b,x ; pla sta #TOSl,b,x pla sta #TOSh,b,x ; end jmp inst_dr ; --------------------------------------------------------- ; ## di (20) stack: xy-rq | - divide & remainder ; ; void inst_di() { ; CELL a, b; ; a = TOS; ; b = NOS; ; #ifndef NOCHECKS ; if (a == 0) { ; printf("\nERROR (nga/inst_di): Division by zero\n"); ; exit(1); ; } ; #endif ; TOS = b / a; ; NOS = b % a; ; } ; XXX - now all operation are unsigned, change this! .warn "inst_di is unsigned, change it" inst_di ldx SP lda #TOSl,b,x bne di4 lda #TOSh,b,x bne di4 .sdb `err_0div ldx #<>err_0div jsr prints .sdb MEM_SEGMENT .setaxl lda #CELL_MAX-1 sta IP rts di4 lda #NOSl,b,x ; NOS to TMPb via TMP(a) sta TMP lda #NOSh,b,x sta TMP+2 bit TMP+2 bpl di3 inc TMPd jsr negate_tmp di3 lda TMP ; NOS from TMP(a) to TMPb sta TMPb lda TMP+2 sta TMPb+2 lda #TOSl,b,x ; TOS to TMP(a) sta TMP lda #TOSh,b,x sta TMP+2 bit TMP+2 bpl di2 inc TMPd jsr negate_tmp di2 stz #TOSl,b,x ; prepare result space stz #TOSh,b,x stz #NOSl,b,x stz #NOSh,b,x di0 lda TMPb ; is NOS 0) ; NOS = x >> y | ~(~0U >> y); ; else ; NOS = x >> y; ; } ; inst_dr(); ; } ; 1. because effective shift for a 32bit value is... 32 ; there is no need in using high word in shift count, ; low word is sufficient for 65535 shifts ; 2. because there is no need in shifting more than 32 ; times, then value of low word is masked to six lower ; bits ; NOTE: code would be simpler if in case of separate shift ; operations (i.e. shift right/shift left) in muri ; inst_sh ldx SP ; check if shift count is positive or negative bit #TOSh,b,x bpl shr_main ; shift to right ; we shifting left, so we need to negate arg jsr negate_tos lda #TOSl,b,x and #63 ; we need only low 6 bits bne + ; do something if > 0 jmp inst_dr + tay ; shifting left is the same for neg and pos vals shl_main asl #NOSl,b,x rol #NOSh,b,x dey bne shl_main jmp inst_dr ; shift right --------------------------------- shr_main lda #TOSl,b,x and #63 ; we need only low 6 bits bne + ; do something if > 0 jmp inst_dr + tay ; did we shifting negative or positive value? bit #NOSh,b,x bmi shr_neg shr_pos lsr #NOSh,b,x ror #NOSl,b,x dey bne shr_pos jmp inst_dr shr_neg clc ror #NOSh,b,x ror #NOSl,b,x dey bne shr_neg jmp inst_dr ; additional routines for shifting ------------ negate_tos nop jsr invert_tos inc #TOSl,b,x ; STACKBASE+0,x bne + inc #TOSh,b,x ; STACKBASE+2,x + rts invert_tos lda #TOSl,b,x ; STACKBASE+0,x eor #$FFFF sta #TOSl,b,x ; STACKBASE+0,x lda #TOSh,b,x ; STACKBASE+2,x eor #$FFFF sta #TOSh,b,x ; STACKBASE+2,x rts ; --------------------------------------------------------- ; ## zr (25) stack: n-? | - zero return ; ; returns from a subroutine if the top item on the stack is zero. ; If not, it acts like a NOP instead. ; ; void inst_zr() { ; if (TOS == 0) { ; inst_dr(); ; ip = TORS; ; rp--; ; } ; } inst_zr ldx SP lda #TOSl,b,x bne zr_quit lda #TOSh,b,x bne zr_quit do_zr jsr inst_dr ldy RP lda #TRSl,b,y sta IP jsr update_ipptr tya sec sbc #CELL_SIZE sta RP zr_quit rts ; --------------------------------------------------------- ; ## ha (26) stack: - | - halt inst_ha lda #CELL_MAX-1 ; XXX - change it sta IP rts ; --------------------------------------------------------- ; ## ie (27) stack: -n | - i/o enumerate inst_ie lda SP clc adc #CELL_SIZE ; 4 bytes sta SP tax lda #NUM_DEVICES sta #TOSl,b,x stz #TOSh,b,x rts ; --------------------------------------------------------- ; ## iq (28) stack: n-xy | - i/o query ; ; void inst_iq() { ; CELL Device = TOS; ; inst_dr(); ; IO_queryHandlers[Device](); ; } inst_iq ldx SP lda #TOSl,b,x pha jsr inst_dr jmp io_query ; ## ii (29) stack: ...n- | - i/o invoke ; ; void inst_ii() { ; CELL Device = TOS; ; inst_dr(); ; IO_deviceHandlers[Device](); ; } ; ; void generic_output() { ; putc(stack_pop(), stdout); ; fflush(stdout); ;} inst_ii ldx SP lda #TOSl,b,x pha jsr inst_dr jmp io_handle ; --------------------------------------------------------- ; device support ; --------------------------------------------------------- ; number of device on stack io_query ; numbers are counted from 0, so val should be ; lower than number of devices ply cpy #NUM_DEVICES bcc query lda #CELL_MAX-1 sta IP ;wdm #KILL ; effective error query lda SP clc adc #4 sta SP tax tya sta #TOSl,b,x ; device number stz #TOSh,b,x bne is_key is_output jmp version0 ; output ver0 is_key cmp #1 bne unknown jmp version0 ; keyboard ver0 unknown jsr inst_dr ; drop already put dev no rts ; never reachable version0 stz #NOSl,b,x stz #NOSh,b,x rts ; --------------------------------------------------------- ; number of device on stack io_handle ; numbers are counted from 0, so val should be ; lower than number of devices ply cpy #NUM_DEVICES bcc interact lda #CELL_MAX-1 sta IP ;wdm #KILL ; stop - error interact cpy #0 beq screen ; crude, but should work ; keyboard input lda SP clc adc #4 sta SP tax ;wdm #TRACE_OFF jsl C256_GETCHW ; all regs preserved here ;wdm #TRACE_ON .setaxl ; redundant and #$00ff ; only byte lower is needed cmp #$0d ; change 0d to 0a bne + lda #$0a + nop sta #TOSl,b,x stz #TOSh,b,x rts ; screen output screen ldx SP txa sec sbc #4 sta SP ; SP is new but X point to previous element lda #TOSl,b,x and #$00ff cmp #$0a bne + lda #$0d + nop ;wdm #TRACE_OFF jsl C256_PUTC ;wdm #TRACE_ON .setaxl ; redundant rts .warn "Code size: ", repr(* - main) ; --------------------------------------------------------- ; # messages ; a counted-string experiment pstring .macro txt .word(len(\txt)) .text \txt .endm ; zero-terminated strings msg_banner .text $d, "RETRO/816 - NGA/816-32 2021-02-21", $d, $0 msg_mclean .text "cleaning memory...", $d, $0 msg_sclean .text "cleaning stack...", $d, $0 msg_copy .text "copying image...", $d, $0 msg_end .text "NGA finished, press any key to restart", $d, $0 err_uf .text "ERROR: stack underflow, re-starting system!", $d, $0 err_0div .text "ERROR: division-by-zero, re-starting system!", $d, $0 err_halt .text "INFO: halt op called! Going to infinite loop.", $d, $0 err_memuf .text "ERROR: read from unknown bad, negative mem addr!", $d, $0 ; --------------------------------------------------------- ; # forth image ; image create by standard RETRO tools ; cp ngaImage barebones.image ; ./bin/retro-extend barebones.image interface/barebones.forth ; IMAGE_SRC .binary "barebones.image" IMAGE_END = * IMAGE_SIZE = IMAGE_END - IMAGE_SRC ; eof