C64-dev/newLang/tests/compiler/iftable-test.s

; E06-S03: interface method table fixture in x128.
;
; The fixture fills the real parser tables (tb_set) with two interfaces and two
; classes, supplies method addresses, and runs src/compiler/iftables.s:
;
;   IFOO slots: 0 ALPHA, 1 BETA      IBAR slots: 0 ALPHA (same signature)
;   A implements IFOO, IBAR          B implements IFOO
;
; It checks:
;   - one table per implemented interface, in implements order, slots in
;     interface order, two bytes per slot;
;   - class B emits its own distinct table;
;   - A's single ALPHA method fills IFOO slot 0 and IBAR slot 0;
;   - a missing address is IT_ERR_UNSET and leaves no table or watermark change;
;   - a table that cannot fit the buffer is IT_ERR_SPACE, also rolled back;
;   - the MAP gains one TABLE record per table with its address and slots.
;
; MB_DATA flags 0..7 report the eight phases; MB_ADDR holds the last step.

.setcpu "6502"
.include "../../src/common/c128.inc"
.include "../../src/common/mailbox.inc"
.include "../../src/common/formats.inc"
.include "../../src/common/parser.inc"
.include "../../src/common/iftables.inc"
.include "../../src/common/ifcalls.inc"

.import mmu_init, mmu_bank0, mmu_shutdown
.import out_begin, out_startup, out_finish, out_abort
.import out_load, out_entry, out_err, out_table_count
.import out_table, out_table_iface, out_table_iface_len
.import out_table_addr, out_table_slots, out_table_data
.import tb_get, tb_set
.import it_begin, it_set_addr, it_class, it_find
.import it_error, it_count, it_used, it_data
.import it_class_ids, it_iface_ids, it_table_addrs, it_slots, it_offsets
.import iface_slot, is_error

TABLE_BASE = $B000

.macro STEP n
        lda #n
        sta MB_ADDR
.endmacro

.macro TBSET col, row, val
        lda #col
        ldy #row
        ldx #val
        jsr tb_set
.endmacro

.macro SETADDR label, row
        lda #<label
        ldx #>label
        ldy #row
        jsr it_set_addr
.endmacro

.macro ABORT code
        bcc :+
        lda #code
        sta MB_ADDR+1
        jmp @p6_abort
:
.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"
p:      .res 2
q:      .res 2

.segment "STARTUP"
.export test_entry, test_end
.export m_alpha_a, m_beta_a, m_gamma_a, m_alpha_b, m_beta_b
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+1
        sta fail_mask
        ldx #$07
        lda #$00
@flags: sta MB_DATA,x
        dex
        bpl @flags

        jsr mmu_init
        jsr mmu_bank0

        ; -------------------------------------------------- parser tables
        STEP $01
        ; IFOO (row 1), IBAR (row 2), A (row 3), B (row 4)
        TBSET C_TYPE_KIND, 1, TYPE_INTERFACE
        TBSET C_TYPE_MFIRST, 1, 0
        TBSET C_TYPE_MCOUNT, 1, 2
        TBSET C_TYPE_KIND, 2, TYPE_INTERFACE
        TBSET C_TYPE_MFIRST, 2, 2
        TBSET C_TYPE_MCOUNT, 2, 1
        TBSET C_TYPE_KIND, 3, TYPE_CLASS
        TBSET C_TYPE_MFIRST, 3, 3
        TBSET C_TYPE_MCOUNT, 3, 3
        TBSET C_TYPE_IFIRST, 3, 0
        TBSET C_TYPE_ICOUNT, 3, 2
        TBSET C_TYPE_KIND, 4, TYPE_CLASS
        TBSET C_TYPE_MFIRST, 4, 6
        TBSET C_TYPE_MCOUNT, 4, 2
        TBSET C_TYPE_IFIRST, 4, 2
        TBSET C_TYPE_ICOUNT, 4, 1

        ; members: 0,1 IFOO ALPHA/BETA; 2 IBAR ALPHA; 3-5 A; 6,7 B
        TBSET C_MEM_NAME, 0, 1
        TBSET C_MEM_FLAGS, 0, MF_METHOD
        TBSET C_MEM_SLOT, 0, 0
        TBSET C_MEM_NAME, 1, 2
        TBSET C_MEM_FLAGS, 1, MF_METHOD
        TBSET C_MEM_SLOT, 1, 1
        TBSET C_MEM_NAME, 2, 1
        TBSET C_MEM_FLAGS, 2, MF_METHOD
        TBSET C_MEM_SLOT, 2, 0
        TBSET C_MEM_NAME, 3, 1
        TBSET C_MEM_FLAGS, 3, MF_METHOD
        TBSET C_MEM_NAME, 4, 2
        TBSET C_MEM_FLAGS, 4, MF_METHOD
        TBSET C_MEM_NAME, 5, 3
        TBSET C_MEM_FLAGS, 5, MF_METHOD
        TBSET C_MEM_NAME, 6, 1
        TBSET C_MEM_FLAGS, 6, MF_METHOD
        TBSET C_MEM_NAME, 7, 2
        TBSET C_MEM_FLAGS, 7, MF_METHOD

        ; implements rows: A->IFOO, A->IBAR, B->IFOO
        TBSET C_IMPL_IFACE, 0, 1
        TBSET C_IMPL_IFACE, 1, 2
        TBSET C_IMPL_IFACE, 2, 1

        STEP $02
        lda #<TABLE_BASE
        ldx #>TABLE_BASE
        jsr it_begin
        SETADDR m_alpha_a, 3
        SETADDR m_beta_a, 4
        SETADDR m_gamma_a, 5
        SETADDR m_alpha_b, 6
        SETADDR m_beta_b, 7

        lda #3
        jsr it_class
        bcc :+
        jmp @fail
:       lda #4
        jsr it_class
        bcc :+
        jmp @fail
:

        ; 0: class A's two tables are ALPHA/BETA then ALPHA.
        STEP $10
        CHK it_data+0, <m_alpha_a
        CHK it_data+1, >m_alpha_a
        CHK it_data+2, <m_beta_a
        CHK it_data+3, >m_beta_a
        CHK it_data+4, <m_alpha_a
        CHK it_data+5, >m_alpha_a
        lda #$01
        sta MB_DATA+0

        ; 1: three records with the expected classes, interfaces, addresses.
        STEP $11
        CHK it_count, 3
        CHK it_class_ids+0, 3
        CHK it_class_ids+1, 3
        CHK it_class_ids+2, 4
        CHK it_iface_ids+0, 1
        CHK it_iface_ids+1, 2
        CHK it_iface_ids+2, 1
        CHK it_slots+0, 2
        CHK it_slots+1, 1
        CHK it_slots+2, 2
        CHK it_table_addrs+0, <TABLE_BASE
        CHK it_table_addrs+1, >TABLE_BASE
        CHK it_table_addrs+2, <(TABLE_BASE + 4)
        CHK it_table_addrs+3, >(TABLE_BASE + 4)
        CHK it_table_addrs+4, <(TABLE_BASE + 6)
        CHK it_table_addrs+5, >(TABLE_BASE + 6)
        CHK it_offsets+0, 0
        CHK it_offsets+1, 0
        CHK it_offsets+2, 4
        CHK it_offsets+3, 0
        CHK it_offsets+4, 6
        CHK it_offsets+5, 0
        lda #$01
        sta MB_DATA+1

        ; 2: class B's table is distinct and uses its own methods.
        STEP $12
        CHK it_data+6, <m_alpha_b
        CHK it_data+7, >m_alpha_b
        CHK it_data+8, <m_beta_b
        CHK it_data+9, >m_beta_b
        lda #$01
        sta MB_DATA+2

        ; 3: one method populated IFOO slot 0 and IBAR slot 0.
        STEP $13
        CHK it_data+4, <m_alpha_a
        CHK it_data+5, >m_alpha_a
        lda #$01
        sta MB_DATA+3

        ; 4: a missing address refuses the class and rolls back.
        STEP $20
        lda #$00
        ldx #$00
        ldy #4
        jsr it_set_addr
        lda #3
        jsr it_class
        bcs :+
        jmp @fail
:
        CHK it_error, IT_ERR_UNSET
        CHK it_count, 3
        CHK it_used, 10
        CHK it_used+1, 0
        SETADDR m_beta_a, 4
        lda #$01
        sta MB_DATA+4

        ; 5: a table larger than the buffer refuses the class.
        STEP $21
        TBSET C_TYPE_MCOUNT, 1, 255
        lda #3
        jsr it_class
        bcs :+
        jmp @fail
:
        CHK it_error, IT_ERR_SPACE
        CHK it_count, 3
        CHK it_used, 10
        TBSET C_TYPE_MCOUNT, 1, 2
        lda #$01
        sta MB_DATA+5

        ; 6: the MAP gains one TABLE record per emitted table.
        STEP $22
        lda #<PRG_LOAD_ADDR
        sta out_load
        lda #>PRG_LOAD_ADDR
        sta out_load+1
        lda #<PRG_ENTRY_ADDR
        sta out_entry
        lda #>PRG_ENTRY_ADDR
        sta out_entry+1
        lda #<name_source
        ldx #>name_source
        ldy #name_source_len
        jsr out_begin
        ABORT $C1
        jsr out_startup
        ABORT $C2
        ldx #0
        jsr set_out_table
        lda #<name_a
        ldx #>name_a
        ldy #name_a_len
        jsr out_table
        ABORT $C3
        ldx #1
        jsr set_out_table
        lda #<name_a
        ldx #>name_a
        ldy #name_a_len
        jsr out_table
        ABORT $C4
        ldx #2
        jsr set_out_table
        lda #<name_b
        ldx #>name_b
        ldy #name_b_len
        jsr out_table
        ABORT $C5
        jsr out_finish
        ABORT $C6
        CHK out_table_count, 3
        lda #$01
        sta MB_DATA+6
        jmp @p7
@p6_abort:
        lda out_err
        sta MB_ADDR
        jsr out_abort
        jmp @fail

        ; 7: the watermark and record count match the three tables, and
        ; it_find selects a table by class and interface.
@p7:
        STEP $23
        CHK it_used, 10
        CHK it_used+1, 0
        CHK it_count, 3

        ; A implements IFOO at $B000 and IBAR at $B004.
        STEP $30
        lda #3
        ldx #1
        jsr it_find
        bcc :+
        jmp @fail
:       cmp #<TABLE_BASE
        beq :+
        jmp @fail
:       cpx #>TABLE_BASE
        beq :+
        jmp @fail
:
        STEP $31
        lda #3
        ldx #2
        jsr it_find
        bcc :+
        jmp @fail
:       cmp #<(TABLE_BASE + 4)
        beq :+
        jmp @fail
:       cpx #>(TABLE_BASE + 4)
        beq :+
        jmp @fail
:
        ; B implements IFOO at $B006, not IBAR.
        STEP $32
        lda #4
        ldx #1
        jsr it_find
        bcc :+
        jmp @fail
:       cmp #<(TABLE_BASE + 6)
        beq :+
        jmp @fail
:       cpx #>(TABLE_BASE + 6)
        beq :+
        jmp @fail
:
        STEP $33
        lda #4
        ldx #2
        jsr it_find
        bcs :+                    ; a refusal is the expected result here
        jmp @fail
:       CHK it_error, IT_ERR_IFACE
        CHK it_count, 3

        ; A call site resolves its slot from the interface declaration:
        ; IFOO ALPHA=0, BETA=1; IBAR ALPHA=0; IBAR GAMMA does not exist, and a
        ; class name is not an interface.
        STEP $34
        lda #1
        ldx #1
        jsr iface_slot
        bcc :+
        jmp @fail
:       cmp #0
        beq :+
        jmp @fail
:       CHK is_error, IS_OK

        STEP $35
        lda #1
        ldx #2
        jsr iface_slot
        bcc :+
        jmp @fail
:       cmp #1
        beq :+
        jmp @fail
:       CHK is_error, IS_OK

        STEP $36
        lda #2
        ldx #1
        jsr iface_slot
        bcc :+
        jmp @fail
:       cmp #0
        beq :+
        jmp @fail
:       CHK is_error, IS_OK

        STEP $37
        lda #2
        ldx #3
        jsr iface_slot
        bcs :+                    ; no such method: a refusal is expected
        jmp @fail
:       CHK is_error, IS_ERR_METHOD

        STEP $38
        lda #3
        ldx #1
        jsr iface_slot
        bcs :+                    ; a class is not an interface
        jmp @fail
:       CHK is_error, IS_ERR_METHOD
        lda #$01
        sta MB_DATA+7

@report:
        ; fail_mask and the messages live above $4000 (MAIN), so decide the
        ; status and copy the text while MAIN is still mapped: mmu_shutdown
        ; restores the system mapping, and only SCRATCH ($1B00) stays put.
        lda fail_mask
        sta msg_fail
        lda #MB_ST_FAIL
        ldx fail_mask
        bne @status
        lda #MB_ST_PASS
@status:
        sta MB_STATUS
        lda #<ok_message
        sta p
        lda #>ok_message
        sta p+1
        lda msg_fail
        beq @copy
        lda #<fail_message
        sta p
        lda #>fail_message
        sta p+1
@copy:  ldy #$00
@cp:    lda (p),y
        sta msg_buf,y
        beq @copied
        iny
        bne @cp
@copied:
        jsr mmu_shutdown
        ldy #$00
@print: lda msg_buf,y
        beq @end
        sty msg_idx
        jsr CHROUT
        ldy msg_idx
        iny
        bne @print
@end:   rts

@fail:
        lda #$01
        sta fail_mask
        jmp @report

.segment "CODE"
; Method stubs the tables point at.
m_alpha_a:
        rts
m_beta_a:
        rts
m_gamma_a:
        rts
m_alpha_b:
        rts
m_beta_b:
        rts

; X = table index -> out_table_addr/slots/data/iface.
set_out_table:
        stx rec_i
        lda #<it_table_addrs
        sta p
        lda #>it_table_addrs
        sta p+1
        jsr add_2x
        ldy #0
        lda (p),y
        sta out_table_addr
        iny
        lda (p),y
        sta out_table_addr+1
        ldx rec_i
        lda it_slots,x
        sta out_table_slots
        lda #<it_offsets
        sta p
        lda #>it_offsets
        sta p+1
        jsr add_2x
        ldy #0
        lda (p),y
        sta q
        iny
        lda (p),y
        sta q+1
        clc
        lda #<it_data
        adc q
        sta out_table_data
        lda #>it_data
        adc q+1
        sta out_table_data+1
        ldx rec_i
        cpx #1
        beq @ibar
        lda #<name_ifoo
        sta out_table_iface
        lda #>name_ifoo
        sta out_table_iface+1
        lda #name_ifoo_len
        sta out_table_iface_len
        rts
@ibar:
        lda #<name_ibar
        sta out_table_iface
        lda #>name_ibar
        sta out_table_iface+1
        lda #name_ibar_len
        sta out_table_iface_len
        rts

; p = p + 2 * rec_i.
add_2x:
        lda rec_i
        asl a
        clc
        adc p
        sta p
        bcc :+
        inc p+1
:       rts

.segment "RODATA"
name_source:     .byte "IFTTEST.N8"
name_source_len = * - name_source
name_a:          .byte "A"
name_a_len = * - name_a
name_b:          .byte "B"
name_b_len = * - name_b
name_ifoo:       .byte "IFOO"
name_ifoo_len = * - name_ifoo
name_ibar:       .byte "IBAR"
name_ibar_len = * - name_ibar
messages:
ok_message:      .byte "NOVA128 IFTABLE TEST OK", $0D, $00
fail_message:    .byte "NOVA128 IFTABLE TEST FAIL", $0D, $00

.segment "SCRATCH"
msg_buf:         .res 32
msg_fail:        .res 1
msg_idx:         .res 1

.segment "BSS"
fail_mask:       .res 1
rec_i:           .res 1
test_end: