retroforth/vm/nga-816/barebones.asm
crc af3583e12a nga-816: pull latest changes from Piotr
FossilOrigin-Name: 4a42046dbc389b6d347e293894730d54fc4a0da8b0608385eba279be4f408810
2021-03-10 15:03:32 +00:00

1572 lines
36 KiB
NASM

; Copyright 2021 Piotr Meyer <aniou@smutek.pl>
;
; 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<TOS?
cmp TMPa
lda TMPb+2
sbc TMPa+2
bvc di1
eor #$80
di1 bmi finish ; yes, NOS<TOS
sec
lda TMPb
sbc TMPa
sta TMPb
lda TMPb+2
sbc TMPa+2
sta TMPb+2
; increase result
inc #TOSl,b,x
bne di0 ; overflow means high+=1
inc #TOSh,b,x
bra di0
finish lda TMPb ; remainder
sta #NOSl,b,x
lda TMPb+2
sta #NOSh,b,x
rts
; additional routines for shifting ------------
negate_tmp
jsr invert_tmp
inc TMP
bne +
inc TMP+2
+ rts
invert_tmp
lda TMP
eor #$FFFF
sta TMP
lda TMP+2
eor #$FFFF
sta TMP+2
rts
; ---------------------------------------------------------
; ## an (21) stack: xy-n | - bitwise and
;
; void inst_an() {
; NOS = TOS & NOS;
; inst_dr();
; }
inst_an
ldx SP
lda #NOSl,b,x
and #TOSl,b,x
sta #NOSl,b,x
lda #NOSh,b,x
and #TOSh,b,x
sta #NOSh,b,x
jmp inst_dr
; ---------------------------------------------------------
; ## or (22) stack: xy-n | - bitwise or
;
; void inst_an() {
; NOS = TOS | NOS;
; inst_dr();
; }
inst_or
ldx SP
lda #NOSl,b,x
ora #TOSl,b,x
sta #NOSl,b,x
lda #NOSh,b,x
ora #TOSh,b,x
sta #NOSh,b,x
jmp inst_dr
; ---------------------------------------------------------
; ## xo (23) stack: xy-n | - bitwise xor
;
; void inst_an() {
; NOS = TOS ^ NOS;
; inst_dr();
; }
inst_xo
ldx SP
lda #NOSl,b,x
eor #TOSl,b,x
sta #NOSl,b,x
lda #NOSh,b,x
eor #TOSh,b,x
sta #NOSh,b,x
jmp inst_dr
; ---------------------------------------------------------
; ## sh (24) stack: xy-n | - shift
;
; void inst_sh() {
; CELL y = TOS;
; CELL x = NOS;
; if (TOS < 0)
; NOS = NOS << (TOS * -1);
; else {
; if (x < 0 && y > 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