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

; E05-S02: class descriptor and object-header test in x128.
;
; The fixture checks the packed descriptor ABI and its runtime accessors:
;   EMPTY: size 7, no destructor, no interfaces
;   BOX:   size 35, destructor, one interface-directory entry
; It then writes CLASSTEST.PRG/MAP through the real output writer. MB_DATA
; flags 0..7 report descriptor, size, destructor, interface, and MAP success.

.setcpu "6502"
.include "../../src/common/c128.inc"
.include "../../src/common/mailbox.inc"
.include "../../src/common/formats.inc"
.include "../../src/common/class.inc"

.import mmu_init, mmu_bank0, mmu_shutdown
.import out_begin, out_startup, out_finish, out_abort
.import out_load, out_entry, out_err
.import out_class, out_class_size, out_class_destroy
.import out_class_ifaces, out_class_ifdir
.import obj_class, obj_size, obj_destroy, obj_iface_dir

.export destroy_b, iface_dir

.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_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 fail_mask
        sta MB_CODE
        sta MB_CODE+1
        ldx #$07
@flags: sta MB_DATA,x
        dex
        bpl @flags

        jsr mmu_init
        jsr mmu_bank0

        ; ------------------------------------------------ descriptor: EMPTY
        lda #<obj_empty
        ldx #>obj_empty
        jsr obj_class
        bcs @p0_fail
        cmp #<desc_empty
        bne @p0_fail
        cpx #>desc_empty
        bne @p0_fail
        lda #$00                   ; null object and null descriptor pointer
        ldx #$00
        jsr obj_class
        bcc @p0_fail
        lda #$01
        sta MB_DATA+0
        jmp @p1
@p0_fail:
        lda #$01
        jsr fail

@p1:    ; ------------------------------------------------------ size: EMPTY
        lda #<obj_empty
        ldx #>obj_empty
        jsr obj_size
        bcs @p1_fail
        cmp #7
        bne @p1_fail
        cpx #$00
        bne @p1_fail
        lda #$01
        sta MB_DATA+1
        jmp @p2
@p1_fail:
        lda #$02
        jsr fail

@p2:    ; -------------------------------------------------- destructor: EMPTY
        lda #<obj_empty
        ldx #>obj_empty
        jsr obj_destroy
        bcs @p2_fail
        cmp #$00
        bne @p2_fail
        cpx #$00
        bne @p2_fail
        lda #$01
        sta MB_DATA+2
        jmp @p3
@p2_fail:
        lda #$04
        jsr fail

@p3:    ; ------------------------------------------------- descriptor: BOX
        lda #<obj_box
        ldx #>obj_box
        jsr obj_class
        bcs @p3_fail
        cmp #<desc_box
        bne @p3_fail
        cpx #>desc_box
        bne @p3_fail
        lda #$01
        sta MB_DATA+3
        jmp @p4
@p3_fail:
        lda #$08
        jsr fail

@p4:    ; ------------------------------------------------------ size: BOX
        lda #<obj_box
        ldx #>obj_box
        jsr obj_size
        bcs @p4_fail
        cmp #35
        bne @p4_fail
        cpx #$00
        bne @p4_fail
        lda #$01
        sta MB_DATA+4
        jmp @p5
@p4_fail:
        lda #$10
        jsr fail

@p5:    ; ------------------------------------------------- destructor: BOX
        lda #<obj_box
        ldx #>obj_box
        jsr obj_destroy
        bcs @p5_fail
        cmp #<destroy_b
        bne @p5_fail
        cpx #>destroy_b
        bne @p5_fail
        lda #$01
        sta MB_DATA+5
        jmp @p6
@p5_fail:
        lda #$20
        jsr fail

@p6:    ; ------------------------------------------------ interface directory
        lda #<obj_box
        ldx #>obj_box
        jsr obj_iface_dir
        bcs @p6_fail
        cmp #<iface_dir
        bne @p6_fail
        cpx #>iface_dir
        bne @p6_fail
        cpy #1
        bne @p6_fail
        lda #$01
        sta MB_DATA+6
        jmp @p7
@p6_fail:
        lda #$40
        jsr fail

@p7:    ; -------------------------------------------------------- MAP output
        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
        bcs @p7_abort
        jsr out_startup
        bcs @p7_abort

        lda #7                     ; EMPTY: size 7, no destructor/interface
        sta out_class_size
        lda #$00
        sta out_class_size+1
        sta out_class_destroy
        sta out_class_destroy+1
        sta out_class_ifaces
        sta out_class_ifdir
        sta out_class_ifdir+1
        lda #<name_empty
        ldx #>name_empty
        ldy #name_empty_len
        jsr out_class
        bcs @p7_abort

        lda #35                    ; BOX: destructor and one interface
        sta out_class_size
        lda #$00
        sta out_class_size+1
        lda #<destroy_b
        sta out_class_destroy
        lda #>destroy_b
        sta out_class_destroy+1
        lda #1
        sta out_class_ifaces
        lda #<iface_dir
        sta out_class_ifdir
        lda #>iface_dir
        sta out_class_ifdir+1
        lda #<name_box
        ldx #>name_box
        ldy #name_box_len
        jsr out_class
        bcs @p7_abort

        jsr out_finish
        bcs @p7_fail
        lda #$01
        sta MB_DATA+7
        jmp @done
@p7_abort:
        lda out_err
        sta MB_ADDR
        jsr out_abort
@p7_fail:
        lda out_err
        sta MB_ADDR
        lda #$80
        jsr fail

@done:
        jsr mmu_shutdown
        lda fail_mask
        sta MB_CODE
        lda #$00
        sta MB_CODE+1
        lda #MB_ST_FAIL
        ldx fail_mask
        bne @status
        lda #MB_ST_PASS
@status:
        sta MB_STATUS
        lda fail_mask
        beq @ok_message
        ldy #fail_message - messages
        bne @print
@ok_message:
        ldy #ok_message - messages
@print: lda messages,y
        beq @end
        sty print_y
        jsr CHROUT
        ldy print_y
        iny
        bne @print
@end:   rts

.segment "CODE"
fail:
        ora fail_mask
        sta fail_mask
        rts

destroy_b:
        rts

method_stub:
        rts

.segment "DATA"
desc_empty:
        .word 7
        .word 0
        .byte 0
        .word 0
        .byte 0
.assert * - desc_empty = CLASS_DESC_SIZE, error, "EMPTY descriptor size"

desc_box:
        .word 35
        .word destroy_b
        .byte 1
        .word iface_dir
        .byte 0
.assert * - desc_box = CLASS_DESC_SIZE, error, "BOX descriptor size"

iface_dir:
        .word iface_stub
        .word iface_table
iface_stub:
        .word 0
iface_table:
        .word method_stub

obj_empty:
        .word desc_empty
        .res 5
obj_box:
        .word desc_box
        .res 33
.assert obj_box - obj_empty = 7, error, "EMPTY object size"
.assert * - obj_box = 35, error, "BOX object size"

.segment "RODATA"
name_source:     .byte "CLASSTEST.N8"
name_source_len = * - name_source
name_empty:      .byte "EMPTY"
name_empty_len = * - name_empty
name_box:        .byte "BOX"
name_box_len = * - name_box
messages:
ok_message:      .byte "NOVA128 CLASS TEST OK", $0D, $00
fail_message:    .byte "NOVA128 CLASS TEST FAIL", $0D, $00

.segment "BSS"
fail_mask:       .res 1
print_y:         .res 1