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

; E03-S01/E03-S02: parser 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
;   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.
;   $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 tb_get, mem_count

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

.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
        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
        jsr parse_file
        jsr diag_finish
        jsr emit
        jsr dump_types
        lda #$FC
        jsr emit
        jsr dump_members
@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
        bne @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 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_COUNT = 28

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
dump:           .res DUMP_SIZE