C64-dev/newLang/tests/parser/parser-test.s

; E03-S01..E03-S04: parser and type-checker test in x128.
;
; For each fixture: src_load, names_init, diag_init (screen off), parse_file,
; diag_finish. Rejected fixtures leave NAME.ERR on the disk for the host to
; compare; accepted fixtures must leave none. The dump records:
;   $FF, fixture index, src_load result, diagnostic count, lowest SP seen
;   by the expression parser ($FF if it never ran)
;   per declared top-level type: kind, line lo, line hi, spelling length,
;   spelling bytes
;   $FC
;   per member row: owner name, member name, flags, type, parameter count,
;   then each parameter's type. A name is a length and its spelling (length
;   0 = none); a type is base, name, length lo, length hi.
;   $F9
;   per interface: name, slot count (member count), then each slot's number
;   and method name in source order (E03-S06)
;   $FA, per class: name, instance size, field count, fields and offsets
;   for the TRACE_INDEX fixture only: $FB, length lo/hi, the expression
;   trace (parser.inc TR_*)
;   $FD
; then $FE at the end. Mailbox: MB_DATA+0/1 dump address, +2/3 length.

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

.import mmu_init, mmu_bank0, mmu_shutdown, mmu_peek1, kcall_inline
.importzp mmu_ptr
.import src_load
.import names_init, name_get, names_count, name_out, name_out_len
.import diag_init, diag_finish, diag_screen
.import parse_file, type_kind, type_line_lo, type_line_hi
.import em_on
.import tb_get, mem_count, ex_trace_on, ex_min_sp
.importzp ex_tp

DUMP_SIZE = $2000

.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"
dump_ptr:       .res 2
fx_ptr:         .res 2
fx_tmp:         .res 2

.segment "STARTUP"
.export test_entry, dump
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_PLATFORM
        sta MB_PRODUCER
        lda #MB_ST_RUNNING
        sta MB_STATUS
        jsr mmu_init
        jsr mmu_bank0
        lda #<dump
        sta dump_ptr
        lda #>dump
        sta dump_ptr+1
        lda #<fixtures
        sta fx_ptr
        lda #>fixtures
        sta fx_ptr+1
        lda #$00
        sta failures
        sta overflow
        sta fx_index

@fixture:
        lda #$FF
        jsr emit
        lda fx_index
        jsr emit
        ldy #0
        lda (fx_ptr),y
        sta name_lo
        iny
        lda (fx_ptr),y
        sta name_hi
        iny
        lda (fx_ptr),y
        sta name_len
        lda name_lo
        ldx name_hi
        ldy name_len
        jsr src_load
        pha
        jsr emit
        pla
        beq @parse
        inc failures
        lda #$00
        jsr emit
        lda #$FF
        jsr emit
        jmp @advance
@parse: jsr names_init
        lda name_lo
        ldx name_hi
        ldy name_len
        jsr diag_init
        lda #$00                   ; ERR files are the evidence; keep it fast
        sta diag_screen
        lda #$00                   ; parser fixtures only type-check
        sta em_on
        lda #<trace_buf
        sta ex_tp
        lda #>trace_buf
        sta ex_tp+1
        lda #$00
        ldx fx_index
        cpx #TRACE_INDEX
        bne :+
        lda #$01
:       sta ex_trace_on
        jsr parse_file
        lda #$00
        sta ex_trace_on
        jsr diag_finish
        jsr emit
        lda ex_min_sp
        jsr emit
        jsr dump_types
        lda #$FC
        jsr emit
        jsr dump_members
        jsr dump_ifaces
        jsr dump_layout
        lda fx_index
        cmp #TRACE_INDEX
        bne @advance
        jsr dump_trace
@advance:
        lda #$FD
        jsr emit
        clc
        lda fx_ptr
        adc #3
        sta fx_ptr
        bcc :+
        inc fx_ptr+1
:       inc fx_index
        lda fx_index
        cmp #FIXTURE_COUNT
        beq :+
        jmp @fixture

:       lda #$FE
        jsr emit
        lda #<dump                 ; report while the private ZP is mapped
        sta MB_DATA+0
        lda #>dump
        sta MB_DATA+1
        sec
        lda dump_ptr
        sbc #<dump
        sta MB_DATA+2
        lda dump_ptr+1
        sbc #>dump
        sta MB_DATA+3
        lda failures               ; everything above $3FFF disappears behind
        ora overflow               ; BASIC ROM after mmu_shutdown: report first
        sta MB_CODE
        bne @fail
        lda #MB_ST_PASS
        ldy #ok_msg - messages     ; may be 0: do not branch on it
        jmp @report
@fail:  lda #MB_ST_FAIL
        ldy #fail_msg - messages
@report:
        sta MB_STATUS
:       lda messages,y
        beq @end
        sty print_y
        jsr kcall_inline
        .word CHROUT
        ldy print_y
        iny
        bne :-
@end:   jsr mmu_shutdown
        plp
        rts

.segment "CODE"

; Emit every name ID that the parser recorded as a top-level type.
dump_types:
        lda #$01
        sta id
@next:  lda id
        cmp names_count
        beq :+
        bcs @done
:       lda #<type_kind
        sta mmu_ptr
        lda #>type_kind
        sta mmu_ptr+1
        ldy id
        jsr mmu_peek1
        beq @skip
        jsr emit
        lda #<type_line_lo
        sta mmu_ptr
        lda #>type_line_lo
        sta mmu_ptr+1
        ldy id
        jsr mmu_peek1
        jsr emit
        lda #<type_line_hi
        sta mmu_ptr
        lda #>type_line_hi
        sta mmu_ptr+1
        ldy id
        jsr mmu_peek1
        jsr emit
        lda id
        jsr name_get
        lda name_out_len
        jsr emit
        ldx #$00
:       cpx name_out_len
        beq @skip
        lda name_out,x
        stx emit_x
        jsr emit
        ldx emit_x
        inx
        bne :-
@skip:  inc id
        bne @next
@done:  rts

; Emit every member row with its parameter types.
dump_members:
        lda #$00
        sta row
@next:  lda row
        cmp mem_count
        bcs @done
        ldy row
        lda #C_MEM_OWNER
        jsr tb_get
        jsr emit_name
        ldy row
        lda #C_MEM_NAME
        jsr tb_get
        jsr emit_name
        ldy row
        lda #C_MEM_FLAGS
        jsr tb_get
        jsr emit
        ldy row
        lda #C_MEM_TBASE
        jsr emit_type
        ldy row
        lda #C_MEM_PCOUNT
        jsr tb_get
        sta pleft
        jsr emit
        ldy row
        lda #C_MEM_PFIRST
        jsr tb_get
        sta prow
@par:   lda pleft
        beq @adv
        ldy prow
        lda #C_PAR_TBASE
        jsr emit_type
        inc prow
        dec pleft
        jmp @par
@adv:   inc row
        jmp @next
@done:  rts

; Emit $F9, then each interface: name, member count, and each member's slot
; number and method name in declaration order.
dump_ifaces:
        lda #$F9
        jsr emit
        lda #$01
        sta id
@next:  lda id
        cmp names_count
        bcc :+
        jmp @done
:       ldy id
        lda #C_TYPE_KIND
        jsr tb_get
        cmp #TYPE_INTERFACE
        beq :+
        jmp @adv
:       lda id
        jsr emit_name
        ldy id
        lda #C_TYPE_MCOUNT
        jsr tb_get
        sta lk_n
        jsr emit
        ldy id
        lda #C_TYPE_MFIRST
        jsr tb_get
        sta lk_row
@slot:  lda lk_n
        beq @adv
        ldy lk_row
        lda #C_MEM_SLOT
        jsr tb_get
        jsr emit
        ldy lk_row
        lda #C_MEM_NAME
        jsr tb_get
        jsr emit_name
        inc lk_row
        dec lk_n
        jmp @slot
@adv:   inc id
        beq @done
        jmp @next
@done:  rts

; Emit $FA, then each class: name, instance size lo/hi, field count, and
; every field's name and offset lo/hi in declaration order.
dump_layout:
        lda #$FA
        jsr emit
        lda #$01
        sta id
@next:  lda id
        cmp names_count
        bcc :+
        jmp @done
:       ldy id
        lda #C_TYPE_KIND
        jsr tb_get
        cmp #TYPE_CLASS
        bne @not_class
        lda id
        jsr emit_name
        ldy id
        lda #C_TYPE_SIZE_LO
        jsr tb_get
        jsr emit
        ldy id
        lda #C_TYPE_SIZE_HI
        jsr tb_get
        jsr emit
        lda id
        jsr count_fields
        jsr emit
        lda #$00
        sta lk_row
@field_loop:
        lda lk_row
        cmp mem_count
        bcs @fields_done
        ldy lk_row
        lda #C_MEM_OWNER
        jsr tb_get
        cmp id
        bne @fnext
        ldy lk_row
        lda #C_MEM_FLAGS
        jsr tb_get
        and #MF_METHOD
        bne @fnext
        ldy lk_row
        lda #C_MEM_NAME
        jsr tb_get
        jsr emit_name
        ldy lk_row
        lda #C_MEM_OFFSET_LO
        jsr tb_get
        jsr emit
        ldy lk_row
        lda #C_MEM_OFFSET_HI
        jsr tb_get
        jsr emit
@fnext: inc lk_row
        jmp @field_loop
@fields_done:
@not_class:
        inc id
        beq @done
        jmp @next
@done:  rts

; A = class name ID; A = number of field rows it owns.
count_fields:
        sta lk_owner
        lda #$00
        sta lk_n
        sta lk_row
@loop:  lda lk_row
        cmp mem_count
        bcs @done
        ldy lk_row
        lda #C_MEM_OWNER
        jsr tb_get
        cmp lk_owner
        bne @next
        ldy lk_row
        lda #C_MEM_FLAGS
        jsr tb_get
        and #MF_METHOD
        bne @next
        inc lk_n
@next:  inc lk_row
        jmp @loop
@done:  lda lk_n
        rts

; Emit $FB, the trace length, and the trace bytes.
dump_trace:
        lda #$FB
        jsr emit
        sec                        ; both bytes before emit: it clears C
        lda ex_tp
        sbc #<trace_buf
        sta trace_len
        lda ex_tp+1
        sbc #>trace_buf
        sta trace_len+1
        lda trace_len
        jsr emit
        lda trace_len+1
        jsr emit
        lda #<trace_buf
        sta fx_tmp
        lda #>trace_buf
        sta fx_tmp+1
@byte:  lda fx_tmp
        cmp ex_tp
        bne :+
        lda fx_tmp+1
        cmp ex_tp+1
        beq @done
:       ldy #$00
        lda (fx_tmp),y
        jsr emit
        inc fx_tmp
        bne @byte
        inc fx_tmp+1
        bne @byte
@done:  rts

; Emit the four type columns starting at column A for row Y.
emit_type:
        sta col
        sty trow
        jsr tb_get                 ; base
        jsr emit
        inc col
        lda col
        ldy trow
        jsr tb_get                 ; name ID
        jsr emit_name
        inc col
        lda col
        ldy trow
        jsr tb_get                 ; length lo
        jsr emit
        inc col
        lda col
        ldy trow
        jsr tb_get                 ; length hi
        jmp emit

; Emit name ID A as length + spelling; 0 emits a zero length.
emit_name:
        cmp #$00
        bne :+
        jmp emit
:       jsr name_get
        lda name_out_len
        jsr emit
        ldx #$00
@byte:  cpx name_out_len
        beq @done
        lda name_out,x
        stx emit_x
        jsr emit
        ldx emit_x
        inx
        bne @byte
@done:  rts

emit:   ldy dump_ptr+1
        cpy #>(dump + DUMP_SIZE)
        bcc @room
        lda #$01
        sta overflow
        rts
@room:  sty emit_y
        ldy #$00
        sta (dump_ptr),y
        ldy emit_y
        inc dump_ptr
        bne :+
        inc dump_ptr+1
:       rts

.segment "RODATA"
.macro FIXTURE name
        .local text, done
        .word text
        .byte done - text
        .pushseg
        .segment "DATA"
text:   .byte name
done:
        .popseg
.endmacro
fixtures:
        FIXTURE "MINIMAL.N8"
        FIXTURE "DECLS.N8"
        FIXTURE "ARRAYS.N8"
        FIXTURE "EXPRS.N8"
        FIXTURE "FORWARD.N8"
        FIXTURE "NULLS.N8"
        FIXTURE "STMTS.N8"
        FIXTURE "BADCHAR.N8"
        FIXTURE "BADCLASS.N8"
        FIXTURE "BADIFACE.N8"
        FIXTURE "BADMETHOD.N8"
        FIXTURE "DUPDECL.N8"
        FIXTURE "IFACEBODY.N8"
        FIXTURE "LINECONT.N8"
        FIXTURE "MISSCLASS.N8"
        FIXTURE "MISSEND.N8"
        FIXTURE "MISSIF.N8"
        FIXTURE "MISSMETH.N8"
        FIXTURE "MULTISTMT.N8"
        FIXTURE "ORDER.N8"
        FIXTURE "UNKNOWN.N8"
        FIXTURE "RECOVER.N8"
        FIXTURE "NOPROG.N8"
        FIXTURE "EOFCLASS.N8"
        FIXTURE "MEMBERS.N8"
        FIXTURE "LIFECYCLE.N8"
        FIXTURE "SCOPES.N8"
        FIXTURE "PRIVATE.N8"
        FIXTURE "PREC.N8"
        FIXTURE "FORMS.N8"
        FIXTURE "SYNTAX.N8"
        FIXTURE "TYPESOK.N8"
        FIXTURE "CONVERT.N8"
        FIXTURE "REFS.N8"
        FIXTURE "OPS.N8"
        FIXTURE "USES.N8"
        FIXTURE "CALLS.N8"
        FIXTURE "LAYOUT.N8"
        FIXTURE "TOOBIG.N8"
        FIXTURE "INTERFACES.N8"
        FIXTURE "IFACEBAD.N8"
FIXTURE_COUNT = 41
TRACE_INDEX = 28                   ; PREC.N8

messages:
ok_msg:    .byte "NOVA128 PARSER TEST OK", $0D, $00
fail_msg:  .byte "NOVA128 PARSER TEST FAIL", $0D, $00

.segment "BSS"
failures:       .res 1
overflow:       .res 1
fx_index:       .res 1
name_lo:        .res 1
name_hi:        .res 1
name_len:       .res 1
id:             .res 1
emit_x:         .res 1
emit_y:         .res 1
print_y:        .res 1
row:            .res 1
prow:           .res 1
pleft:          .res 1
col:            .res 1
trow:           .res 1
lk_owner:       .res 1
lk_row:         .res 1
lk_n:           .res 1
trace_len:      .res 2
trace_buf:      .res 1024
dump:           .res DUMP_SIZE