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

; E05-S03: construction/deletion fixture in x128.
;
; Runs under CR=$0E with a 4K heap at $4000. It checks:
;   - object header and zeroed fields, then init called once with two args;
;   - delete null is a no-op;
;   - delete calls destroy once with self/fields intact and frees the object;
;   - failed allocation does not call init;
;   - a class without a destructor still frees correctly.
;
; MB_DATA flags 0..4 report the five phases.

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

.import pr_char, pr_cr, pr_text
.import heap_init, heap_alloc, heap_free, heap_free_total, heap_error
.import frame_init, frame_enter, frame_leave, frame_push_byte, frame_push_word, frame_discard
.import obj_class
.import obj_new, obj_delete, obj_init_ptr, obj_error

HEAP_BASE  = $4000
HEAP_PAGES = 16

.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_CC
        bcs :+
        jmp @fail
:
.endmacro

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

.macro FAIL_EQ
        bne :+
        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

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

        PHASE 1
        lda #$00
        ldx #>HEAP_BASE
        ldy #HEAP_PAGES
        jsr heap_init
        FAIL_CS
        jsr frame_init
        lda #$00
        sta init_count
        sta destroy_count
        sta init_error

        ; Construct Res(value=$1234, tag=$2A).
        lda #$2A
        jsr frame_push_byte         ; right-to-left: tag first
        lda #$34
        ldx #$12
        jsr frame_push_word         ; then value
        lda #<init_res
        sta obj_init_ptr
        lda #>init_res
        sta obj_init_ptr+1
        lda #<desc_res
        ldx #>desc_res
        jsr obj_new
        FAIL_CS
        sta new_obj
        stx new_obj+1
        lda #3
        ldx #$00
        jsr frame_discard

        lda init_error
        FAIL_NE
        lda init_count
        cmp #1
        FAIL_NE
        lda init_self
        cmp new_obj
        FAIL_NE
        lda init_self+1
        cmp new_obj+1
        FAIL_NE
        lda init_tag
        cmp #$2A
        FAIL_NE
        lda init_word
        cmp #$34
        FAIL_NE
        lda init_word+1
        cmp #$12
        FAIL_NE
        lda init_tag_before
        FAIL_NE
        lda init_word_before
        ora init_word_before+1
        FAIL_NE

        lda new_obj
        ldx new_obj+1
        jsr obj_class
        FAIL_CS
        cmp #<desc_res
        FAIL_NE
        cpx #>desc_res
        FAIL_NE
        lda #$01
        sta MB_DATA+0

        ; delete null must not call destroy.
        PHASE 2
        lda #$00
        ldx #$00
        jsr obj_delete
        FAIL_CS
        lda obj_error
        cmp #OBJ_OK
        FAIL_NE
        lda destroy_count
        FAIL_NE
        lda #$01
        sta MB_DATA+1

        ; Deleting the object calls destroy once, with self and fields intact.
        PHASE 3
        lda new_obj
        ldx new_obj+1
        jsr obj_delete
        FAIL_CS
        lda obj_error
        cmp #OBJ_OK
        FAIL_NE
        lda destroy_count
        cmp #1
        FAIL_NE
        lda destroy_self
        cmp new_obj
        FAIL_NE
        lda destroy_self+1
        cmp new_obj+1
        FAIL_NE
        lda destroy_tag
        cmp #$2A
        FAIL_NE
        lda destroy_word
        cmp #$34
        FAIL_NE
        lda destroy_word+1
        cmp #$12
        FAIL_NE
        lda heap_free_total
        cmp #$00
        FAIL_NE
        lda heap_free_total+1
        cmp #$10
        FAIL_NE
        lda #$01
        sta MB_DATA+2

        ; Allocation failure must not call init.
        PHASE 4
        lda #<init_res
        sta obj_init_ptr
        lda #>init_res
        sta obj_init_ptr+1
        lda #<desc_huge
        ldx #>desc_huge
        jsr obj_new
        FAIL_CC
        lda obj_error
        cmp #OBJ_ERR_HEAP
        FAIL_NE
        lda init_count
        cmp #1
        FAIL_NE
        lda #$01
        sta MB_DATA+3

        ; A class with no destructor still frees its complete object.
        PHASE 5
        lda #$00
        sta obj_init_ptr
        sta obj_init_ptr+1
        lda #<desc_plain
        ldx #>desc_plain
        jsr obj_new
        FAIL_CS
        sta plain_obj
        stx plain_obj+1
        lda plain_obj
        ldx plain_obj+1
        jsr obj_delete
        FAIL_CS
        lda obj_error
        cmp #OBJ_OK
        FAIL_NE
        lda destroy_count
        cmp #1
        FAIL_NE
        lda heap_free_total
        cmp #$00
        FAIL_NE
        lda heap_free_total+1
        cmp #$10
        FAIL_NE
        lda #$01
        sta MB_DATA+4

        TEXT object_ok, 9
        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 object_fail, 11
        jsr pr_cr
@restore:
        lda saved_cr
        sta MMU_CR
        plp
        rts

; init(value as word, tag as byte), arguments at FP+2..FP+4.
init_res:
        sta init_self
        stx init_self+1
        lda #$00
        ldx #$00
        jsr frame_enter
        bcc @entered
        lda #1
        sta init_error
        rts
@entered:
        ldy #2
        lda (FRAME_FP),y
        sta init_word
        iny
        lda (FRAME_FP),y
        sta init_word+1
        iny
        lda (FRAME_FP),y
        sta init_tag

        lda init_self
        sta tptr
        lda init_self+1
        sta tptr+1
        ldy #2
        lda (tptr),y
        sta init_tag_before
        ldy #3
        lda (tptr),y
        sta init_word_before
        iny
        lda (tptr),y
        sta init_word_before+1

        ldy #2
        lda init_tag
        sta (tptr),y
        ldy #3
        lda init_word
        sta (tptr),y
        iny
        lda init_word+1
        sta (tptr),y
        inc init_count
        jsr frame_leave
        clc
        rts

; No-argument destructor; it records self and the fields left by init.
destroy_res:
        sta destroy_self
        stx destroy_self+1
        inc destroy_count
        lda destroy_self
        sta tptr
        lda destroy_self+1
        sta tptr+1
        ldy #2
        lda (tptr),y
        sta destroy_tag
        ldy #3
        lda (tptr),y
        sta destroy_word
        iny
        lda (tptr),y
        sta destroy_word+1
        rts

.segment "DATA"
desc_res:
        .word 5                    ; header + tag + word
        .word destroy_res
        .byte 0
        .word 0
        .byte 0
.assert * - desc_res = CLASS_DESC_SIZE, error, "Res descriptor size"

desc_plain:
        .word 2                    ; header only
        .word 0
        .byte 0
        .word 0
        .byte 0
.assert * - desc_plain = CLASS_DESC_SIZE, error, "plain descriptor size"

desc_huge:
        .word $FFFF
        .word 0
        .byte 0
        .word 0
        .byte 0
.assert * - desc_huge = CLASS_DESC_SIZE, error, "huge descriptor size"

.segment "RODATA"
title:          .byte "NOVA128 OBJECT TEST"
object_ok:      .byte "OBJECT OK"
object_fail:    .byte "OBJECT FAIL"

.segment "BSS"
saved_cr:       .res 1
new_obj:        .res 2
plain_obj:      .res 2
init_count:     .res 1
init_error:     .res 1
init_self:      .res 2
init_word:      .res 2
init_tag:       .res 1
init_tag_before: .res 1
init_word_before: .res 2
destroy_count:  .res 1
destroy_self:   .res 2
destroy_tag:    .res 1
destroy_word:   .res 2
test_end: