C64-dev/newLang/tests/runtime/convert-test.s

; E06-S04: concrete-to-interface conversion fixture in x128.
;
; Runs under CR=$0E on the E06-S01 value ABI, the E06-S02 dispatch core, and
; the E06-S03 table shape. It checks:
;   - assigning a class reference to an interface value writes the object
;     pointer and the interface's method table (if_assign mode 1);
;   - a null object converts to the canonical four zero bytes;
;   - interface-to-interface assignment copies all four bytes verbatim, and a
;     zero source pointer is IF_ERR_NULL;
;   - a four-byte field and array elements at IF_VALUE_SIZE stride keep the
;     pair, and an element address that wraps is IF_ERR_RANGE;
;   - pushing an interface value as an argument leaves the object low byte at
;     FP+2 and restores the frame stack;
;   - a converted value survives the four-byte result area.
;
; The tables below are the shape E06-S03 emits: two-byte method addresses in
; interface slot order, no header. MB_DATA flags 0..5 report the six phases.

.setcpu "6502"
.include "../../src/common/c128.inc"
.include "../../src/common/mailbox.inc"
.include "../../src/common/print.inc"
.include "../../src/common/frames.inc"
.include "../../src/common/interfaces.inc"

.import pr_char, pr_cr, pr_text
.import frame_init, frame_enter, frame_leave, frame_discard
.import if_assign, if_arg_push, if_elem_store, if_elem_load
.import if_is_null, if_ret_store, if_ret_load
.import if_error
.importzp if_obj, if_tab, if_dst, if_src

.macro TEXT src, len
        lda #<src
        ldx #>src
        ldy #len
        jsr pr_text
.endmacro

.macro PHASE n
        lda #n
        sta MB_CODE
        lda #$00
        sta MB_CODE+1
.endmacro

.macro POINT var
        lda #<var
        sta tptr
        lda #>var
        sta tptr+1
.endmacro

.macro SETDST var
        lda #<var
        sta if_dst
        lda #>var
        sta if_dst+1
.endmacro

.macro SETSRC var
        lda #<var
        sta if_src
        lda #>var
        sta if_src+1
.endmacro

.macro OBJECT var
        lda #<var
        sta if_obj
        lda #>var
        sta if_obj+1
.endmacro

.macro TABLE var
        lda #<var
        sta if_tab
        lda #>var
        sta if_tab+1
.endmacro

.macro EXPECT v0, v1, v2, v3
        lda #v0
        sta e0
        lda #v1
        sta e1
        lda #v2
        sta e2
        lda #v3
        sta e3
.endmacro

.macro FAIL_CS
        bcc :+
        jmp @fail
:
.endmacro

.macro FAIL_CC
        bcs :+
        jmp @fail
:
.endmacro

.macro FAIL_NE
        beq :+
        jmp @fail
:
.endmacro

.macro CHK addr, val
        lda addr
        cmp #val
        beq :+
        pha
        lda #<addr
        sta MB_ADDR
        lda #>addr
        sta MB_ADDR+1
        pla
        sta MB_CODE
        lda #$00
        sta MB_CODE+1
        jmp @fail
:
.endmacro

.segment "LOADADDR"
        .word $1C01

.segment "EXEHDR"
        .word basic_end
        .word 10
        .byte $9E
        .byte "7181"
        .byte $00
basic_end:
        .word $0000

.segment "MAILBOX"
        .res MB_SIZE

.segment "ZEROPAGE"
tptr:   .res 2

.segment "STARTUP"
.export test_entry, test_end
test_entry:
        php
        sei
        ldx #MB_SIZE - 1
        lda #$00
@clr:   sta MB_BASE,x
        dex
        bpl @clr
        lda #MB_MAGIC0_VALUE
        sta MB_MAGIC0
        lda #MB_MAGIC1_VALUE
        sta MB_MAGIC1
        lda #MB_PROD_PROGRAM
        sta MB_PRODUCER
        lda #MB_ST_RUNNING
        sta MB_STATUS
        lda #$00
        sta MB_CODE
        sta MB_CODE+1
        sta MB_ADDR
        sta MB_ADDR+1
        sta fail_mask
        ldx #$05
        lda #$00
@flags: sta MB_DATA,x
        dex
        bpl @flags
        lda #$5A
        sta holder
        sta holder+1

        lda MMU_CR
        sta saved_cr
        lda #CR_RAM0_KERNAL
        sta MMU_CR
        lda #PR_CLEAR
        jsr pr_char
        TEXT title, title_len
        jsr pr_cr

        ; 1: a class reference assigns the object/table pair.
        PHASE 1
        OBJECT obj_a_stub
        TABLE tab_a
        lda #<val_a
        ldx #>val_a
        ldy #1
        jsr if_assign
        FAIL_CS
        CHK if_error, IF_OK
        EXPECT <obj_a_stub, >obj_a_stub, <tab_a, >tab_a
        POINT val_a
        jsr cmp_val
        FAIL_CS
        lda #$01
        sta MB_DATA+0

        ; 2: null converts to the canonical four zero bytes.
        PHASE 2
        lda #$00
        sta if_obj
        sta if_obj+1
        TABLE tab_a
        lda #<val_b
        ldx #>val_b
        ldy #1
        jsr if_assign
        FAIL_CS
        CHK if_error, IF_OK
        EXPECT $00, $00, $00, $00
        POINT val_b
        jsr cmp_val
        FAIL_CS
        lda #<val_b
        ldx #>val_b
        jsr if_is_null
        FAIL_CC

        ; A null value assigned verbatim stays canonical.
        SETSRC val_b
        lda #<val_c
        ldx #>val_c
        ldy #0
        jsr if_assign
        FAIL_CS
        POINT val_c
        jsr cmp_val
        FAIL_CS
        lda #$01
        sta MB_DATA+1

        ; 3: interface-to-interface assignment preserves all four bytes.
        PHASE 3
        SETSRC val_a
        lda #<val_d
        ldx #>val_d
        ldy #0
        jsr if_assign
        FAIL_CS
        EXPECT <obj_a_stub, >obj_a_stub, <tab_a, >tab_a
        POINT val_d
        jsr cmp_val
        FAIL_CS

        lda #$00
        sta if_src
        sta if_src+1
        lda #<val_d
        ldx #>val_d
        ldy #0
        jsr if_assign
        FAIL_CC
        CHK if_error, IF_ERR_NULL
        POINT val_d
        jsr cmp_val
        FAIL_CS
        lda #$01
        sta MB_DATA+2

        ; 4: one field and three array elements keep their own values.
        PHASE 4
        SETSRC val_a
        lda #<holder_iface
        ldx #>holder_iface
        ldy #0
        jsr if_assign
        FAIL_CS
        POINT holder_iface
        jsr cmp_val
        FAIL_CS
        CHK holder, $5A
        CHK holder+1, $5A

        SETSRC val_a
        lda #<elems
        ldx #>elems
        ldy #0
        jsr if_elem_store
        FAIL_CS
        lda #<elems
        ldx #>elems
        ldy #2
        jsr if_elem_store
        FAIL_CS
        SETSRC val_b
        lda #<elems
        ldx #>elems
        ldy #1
        jsr if_elem_store
        FAIL_CS

        SETDST val_e
        lda #<elems
        ldx #>elems
        ldy #2
        jsr if_elem_load
        FAIL_CS
        EXPECT <obj_a_stub, >obj_a_stub, <tab_a, >tab_a
        POINT val_e
        jsr cmp_val
        FAIL_CS

        SETDST val_f
        lda #<elems
        ldx #>elems
        ldy #1
        jsr if_elem_load
        FAIL_CS
        EXPECT $00, $00, $00, $00
        POINT val_f
        jsr cmp_val
        FAIL_CS

        SETDST val_g
        lda #<elems
        ldx #>elems
        ldy #0
        jsr if_elem_load
        FAIL_CS
        EXPECT <obj_a_stub, >obj_a_stub, <tab_a, >tab_a
        POINT val_g
        jsr cmp_val
        FAIL_CS

        ; $FF00 + 4*200 wraps past $FFFF.
        SETDST val_g
        lda #$00
        ldx #$FF
        ldy #200
        jsr if_elem_load
        FAIL_CC
        CHK if_error, IF_ERR_RANGE
        lda #$01
        sta MB_DATA+3

        ; 5: an argument push puts the object low byte at FP+2.
        PHASE 5
        jsr frame_init
        lda FRAME_SP
        sta saved_sp
        lda FRAME_SP+1
        sta saved_sp+1
        lda #<val_a
        ldx #>val_a
        jsr if_arg_push
        FAIL_CS
        jsr take_iface
        FAIL_CS
        lda #IF_VALUE_SIZE
        ldx #$00
        jsr frame_discard
        lda FRAME_SP
        cmp saved_sp
        FAIL_NE
        lda FRAME_SP+1
        cmp saved_sp+1
        FAIL_NE

        lda #$00
        ldx #$00
        jsr if_arg_push
        FAIL_CC
        CHK if_error, IF_ERR_NULL
        lda FRAME_SP
        cmp saved_sp
        FAIL_NE
        lda FRAME_SP+1
        cmp saved_sp+1
        FAIL_NE
        lda #$01
        sta MB_DATA+4

        ; 6: a converted value survives the four-byte result area.
        PHASE 6
        lda #<val_d
        ldx #>val_d
        jsr if_ret_store
        FAIL_CS
        lda #<val_c
        ldx #>val_c
        jsr if_ret_load
        FAIL_CS
        EXPECT <obj_a_stub, >obj_a_stub, <tab_a, >tab_a
        POINT val_c
        jsr cmp_val
        FAIL_CS

        OBJECT obj_a_stub
        TABLE tab_b
        lda #<val_e
        ldx #>val_e
        ldy #1
        jsr if_assign
        FAIL_CS
        lda #<val_e
        ldx #>val_e
        jsr if_ret_store
        FAIL_CS
        lda #<val_g
        ldx #>val_g
        jsr if_ret_load
        FAIL_CS
        EXPECT <obj_a_stub, >obj_a_stub, <tab_b, >tab_b
        POINT val_g
        jsr cmp_val
        FAIL_CS
        lda #$01
        sta MB_DATA+5

        TEXT ok_msg, ok_len
        jsr pr_cr
        lda #MB_ST_PASS
        sta MB_STATUS
        lda #$00
        sta MB_CODE
        sta MB_CODE+1
        jmp @restore

@fail:
        lda #MB_ST_FAIL
        sta MB_STATUS
        TEXT fail_msg, fail_len
        jsr pr_cr
@restore:
        lda saved_cr
        sta MMU_CR
        plp
        rts

; Reads the four argument bytes at FP+2..FP+5: object, then table.
take_iface:
        lda #$00
        ldx #$00
        jsr frame_enter
        bcs @bad
        ldy #2
        lda (FRAME_FP),y
        cmp #<obj_a_stub
        bne @bad
        iny
        lda (FRAME_FP),y
        cmp #>obj_a_stub
        bne @bad
        iny
        lda (FRAME_FP),y
        cmp #<tab_a
        bne @bad
        iny
        lda (FRAME_FP),y
        cmp #>tab_a
        bne @bad
        jsr frame_leave
        clc
        rts
@bad:   sec
        rts

; C=1 when the four bytes at tptr differ from e0..e3.
cmp_val:
        ldy #$00
        lda (tptr),y
        cmp e0
        bne @no
        iny
        lda (tptr),y
        cmp e1
        bne @no
        iny
        lda (tptr),y
        cmp e2
        bne @no
        iny
        lda (tptr),y
        cmp e3
        bne @no
        clc
        rts
@no:    sec
        rts

.segment "CODE"
; Method stubs the tables point at, as E06-S03 emits them.
m_alpha_a:
        rts
m_beta_a:
        rts
m_alpha_b:
        rts
m_beta_b:
        rts

.segment "DATA"
obj_a_stub:     .res 2                 ; stands in for an allocated object
tab_a:          .word m_alpha_a, m_beta_a
tab_b:          .word m_alpha_b, m_beta_b
.assert * - tab_a = 2 * 2 * IF_SLOT_SIZE, error, "table size"

.segment "RODATA"
title:          .byte "NOVA128 CONVERT TEST"
title_len = * - title
ok_msg:         .byte "CONVERT OK"
ok_len = * - ok_msg
fail_msg:       .byte "CONVERT FAIL"
fail_len = * - fail_msg

.segment "BSS"
saved_cr:       .res 1
saved_sp:       .res 2
e0:             .res 1
e1:             .res 1
e2:             .res 1
e3:             .res 1
fail_mask:      .res 1
val_a:          .res IF_VALUE_SIZE
val_b:          .res IF_VALUE_SIZE
val_c:          .res IF_VALUE_SIZE
val_d:          .res IF_VALUE_SIZE
val_e:          .res IF_VALUE_SIZE
val_f:          .res IF_VALUE_SIZE
val_g:          .res IF_VALUE_SIZE
holder:         .res 2
holder_iface:   .res IF_VALUE_SIZE
elems:          .res 3 * IF_VALUE_SIZE
test_end: