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

; E06-S05: interface method call fixture in x128.
;
; Runs under CR=$0E on the E06-S01 value ABI, the E06-S02 trampoline, the
; E06-S03 table shape, and the E06-S04 conversion API. It checks:
;   - two classes dispatch the same interface slot to different methods, and
;     self is the underlying object ($1111 / $2222), not the value record;
;   - one class dispatches through two of its interface tables, so the same
;     object reaches different methods by table pointer alone;
;   - a callee can itself make an interface call and pass on a one-byte result;
;   - a byte argument and a two-byte argument arrive at FP+2..FP+4, a two-byte
;     result comes back in A/X, and the caller's frame stack is restored.
;
; The slots are the compile-time interface slots (resolved by the compiler's
; iface_slot in the table fixture); the table pointer is read at run time from
; the value, which is what lets one call site reach two classes.
;
; MB_DATA flags 0..3 report the four 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_push_byte, frame_push_word, frame_discard
.import if_call, if_error

.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 FAIL_CS
        bcc :+
        jmp @fail
:
.endmacro

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

; A/X = self. A method whose self is not its class's object counts the miss
; and returns failure instead of reporting a result.
.macro SELF_IS lo, hi
        cmp #lo
        bne @selfbad
        cpx #hi
        beq @selfok
@selfbad:
        inc self_bad
        lda #$00
        ldx #$00
        rts
@selfok:
.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 "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 self_bad
        sta a_calls
        sta b_calls
        sta leaf_calls
        ldx #$03
@flags: sta MB_DATA,x
        dex
        bpl @flags

        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: one call site, two classes, two methods.
        PHASE 1
        lda #<val_a_foo
        ldx #>val_a_foo
        ldy #0
        jsr if_call
        sta result_a
        lda if_error
        FAIL_NE
        lda result_a
        cmp #$A0
        FAIL_NE
        lda a_calls
        cmp #1
        FAIL_NE

        lda #<val_b_foo
        ldx #>val_b_foo
        ldy #0
        jsr if_call
        sta result_a
        lda if_error
        FAIL_NE
        lda result_a
        cmp #$B0
        FAIL_NE
        lda b_calls
        cmp #1
        FAIL_NE
        lda self_bad
        FAIL_NE
        lda #$01
        sta MB_DATA+0

        ; 2: one class, two interface tables, different methods.
        PHASE 2
        lda #<val_a_bar
        ldx #>val_a_bar
        ldy #0
        jsr if_call
        sta result_a
        lda if_error
        FAIL_NE
        lda result_a
        cmp #$C0
        FAIL_NE
        lda a_calls
        cmp #2
        FAIL_NE
        lda self_bad
        FAIL_NE
        lda #$01
        sta MB_DATA+1

        ; 3: an interface call inside a method, one-byte result passed on.
        PHASE 3
        lda #<val_a_foo
        ldx #>val_a_foo
        ldy #1
        jsr if_call
        sta result_a
        lda if_error
        FAIL_NE
        lda result_a
        cmp #$5B
        FAIL_NE
        lda a_calls
        cmp #3
        FAIL_NE
        lda leaf_calls
        cmp #1
        FAIL_NE
        lda self_bad
        FAIL_NE
        lda #$01
        sta MB_DATA+2

        ; 4: arguments and a two-byte result through an interface call.
        PHASE 4
        jsr frame_init
        lda #$34
        ldx #$12
        jsr frame_push_word       ; arg1 = $1234
        FAIL_CS
        lda #$07
        jsr frame_push_byte       ; arg0 = 7
        FAIL_CS
        lda #<val_a_foo
        ldx #>val_a_foo
        ldy #2
        jsr if_call
        sta result_a
        stx result_x
        lda if_error
        FAIL_NE
        lda #$03
        ldx #$00
        jsr frame_discard
        lda result_a
        cmp #$3B                  ; $1234 + 7
        FAIL_NE
        lda result_x
        cmp #$12
        FAIL_NE
        lda FRAME_SP
        cmp #<FRAME_STACK_TOP
        FAIL_NE
        lda FRAME_SP+1
        cmp #>FRAME_STACK_TOP
        FAIL_NE
        lda a_calls
        cmp #4
        FAIL_NE
        lda self_bad
        FAIL_NE
        lda #$01
        sta MB_DATA+3

        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

.segment "CODE"
; IFOO slot 0 of class A: byte result, self checked.
m_a0:
        SELF_IS $11, $11
        inc a_calls
        lda #$A0
        ldx #$00
        rts

; IFOO slot 1 of class A: calls leaf through val_leaf and adds one.
m_a1:
        SELF_IS $11, $11
        inc a_calls
        lda #<val_leaf
        ldx #>val_leaf
        ldy #$00
        jsr if_call
        sta child
        stx child_x
        lda if_error
        bne @bad
        lda child
        clc
        adc #$01
        ldx #$00
        rts
@bad:   inc self_bad
        lda #$00
        ldx #$00
        rts

; IFOO slot 2 of class A: (byte, word) -> word sum.
m_addw:
        SELF_IS $11, $11
        inc a_calls
        lda #$00
        ldx #$00
        jsr frame_enter
        bcs @bad
        ldy #$02
        lda (FRAME_FP),y
        sta tmp
        iny
        lda (FRAME_FP),y
        clc
        adc tmp
        sta res_lo
        iny
        lda (FRAME_FP),y
        adc #$00
        sta res_hi
        jsr frame_leave
        lda res_lo
        ldx res_hi
        clc
        rts
@bad:   lda #$00
        ldx #$00
        sec
        rts

; IBAR slot 0 of class A: a different method for the same object.
m_abar:
        SELF_IS $11, $11
        inc a_calls
        lda #$C0
        ldx #$00
        rts

; IFOO slot 0 of class B.
m_b0:
        SELF_IS $22, $22
        inc b_calls
        lda #$B0
        ldx #$00
        rts

; Target of the nested call.
m_leaf:
        inc leaf_calls
        lda #$5A
        ldx #$00
        rts

.segment "DATA"
; Object pointers are only identities here; the methods compare them.
val_a_foo:      .word $1111, tab_a_foo
val_a_bar:      .word $1111, tab_a_bar
val_b_foo:      .word $2222, tab_b_foo
val_leaf:       .word $9999, tab_leaf
tab_a_foo:      .word m_a0, m_a1, m_addw
tab_a_bar:      .word m_abar
tab_b_foo:      .word m_b0
tab_leaf:       .word m_leaf
.assert tab_a_bar - tab_a_foo = 3 * IF_SLOT_SIZE, error, "IFOO table size"
.assert tab_b_foo - tab_a_bar = 1 * IF_SLOT_SIZE, error, "IBAR table size"

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

.segment "BSS"
saved_cr:       .res 1
a_calls:        .res 1
b_calls:        .res 1
leaf_calls:     .res 1
self_bad:       .res 1
result_a:       .res 1
result_x:       .res 1
child:          .res 1
child_x:        .res 1
tmp:            .res 1
res_lo:         .res 1
res_hi:         .res 1
test_end: