C64-dev/newLang/src/compiler/interfaces.s

; interfaces.s - interface slot order and class conformance (E03-S06).
;
; Runs once after pass 1, when every interface, class, member, parameter, and
; implements row is recorded:
;   assign_slots   numbers each interface method in declaration order and
;                  stores it in C_MEM_SLOT, so later method tables and the MAP
;                  writer can use a stable slot without re-reading the source;
;   check_interfaces
;                  verifies each class against every interface it implements.
;                  A satisfying method is public and has the same parameter
;                  count, parameter types, and return type. One method may
;                  satisfy identical requirements from several interfaces.
;
; Diagnostics are reported at the class declaration line, column 1:
;   E130  no public method with a required name (missing, field, or private)
;   E131  a public method with that name differs in its signature
;   E132  the differing method matches the same-named requirement of another
;         implemented interface, so the interfaces conflict
;   E133  an implements entry names a class or program, not an interface
; An implements entry that names no declared type is left to pass 2, which
; already reports the unknown name at the source position.
;
; Everything is read through tb_get/tb_set, so this module runs in the normal
; bank-0 compiler state.

.setcpu "6502"
.include "../common/errors.inc"
.include "../common/parser.inc"

.import tb_get, tb_set, names_count
.import diag_report, diag_line, diag_col, diag_arg1, diag_arg1_len
.import name_get, name_out, name_out_len

.export assign_slots, check_interfaces, find_method

.segment "CODE"

; ------------------------------------------------------------- slot order
; Every interface method gets its declaration index: 0, 1, ... in source
; order. Interfaces cannot declare fields, so member rows are signatures.
assign_slots:
        lda #$01
        sta as_id
@next:  lda as_id
        cmp names_count
        bcc :+
        rts
:       ldy as_id
        lda #C_TYPE_KIND
        jsr tb_get
        cmp #TYPE_INTERFACE
        beq :+
        jmp @skip
:       ldy as_id
        lda #C_TYPE_MFIRST
        jsr tb_get
        sta as_row
        ldy as_id
        lda #C_TYPE_MCOUNT
        jsr tb_get
        sta as_n
        lda #$00
        sta as_slot
@slot:  lda as_n
        beq @skip
        ldy as_row
        ldx as_slot
        lda #C_MEM_SLOT
        jsr tb_set
        inc as_row
        inc as_slot
        dec as_n
        bne @slot
@skip:  inc as_id
        bne @next
        rts

; ----------------------------------------------------------- conformance
; For each class in declaration order, walk its implements list in source
; order and each interface's signatures in slot order.
check_interfaces:
        lda #$01
        sta cf_class
@class: lda cf_class
        cmp names_count
        bcc :+
        jmp @done
:       ldy cf_class
        lda #C_TYPE_KIND
        jsr tb_get
        cmp #TYPE_CLASS
        beq :+
        jmp @cnext
:       ldy cf_class
        lda #C_TYPE_ICOUNT
        jsr tb_get
        bne :+
        jmp @cnext               ; no implements list
:       sta cf_count
        ldy cf_class
        lda #C_TYPE_IFIRST
        jsr tb_get
        sta cf_row
        lda #$00
        sta cf_i
@impl:  lda cf_i
        cmp cf_count
        bcc :+
        jmp @cnext
:       ldy cf_row
        lda #C_IMPL_IFACE
        jsr tb_get
        sta cf_iface
        ldy cf_iface
        lda #C_TYPE_KIND
        jsr tb_get
        cmp #TYPE_INTERFACE
        beq @conform
        cmp #$00
        bne :+                    ; unknown: pass 2 reports it
        jmp @inext
:
        ldx cf_iface
        lda #E_IFC_NOT_INTERFACE
        jsr iface_err
        bcc :+
        jmp @stop
:
        jmp @inext
@conform:
        ldy cf_iface
        lda #C_TYPE_MFIRST
        jsr tb_get
        sta cf_req
        ldy cf_iface
        lda #C_TYPE_MCOUNT
        jsr tb_get
        sta cf_n
@req:   lda cf_n
        bne :+
        jmp @inext
:       ldy cf_req
        lda #C_MEM_NAME
        jsr tb_get
        sta cf_name
        lda cf_class
        ldx cf_name
        jsr find_method
        bcc @missing
        sty cf_method
        lda #C_MEM_FLAGS
        jsr tb_get
        and #MF_PRIVATE
        beq @sig
        jmp @missing              ; private methods do not implement
@sig:   lda cf_req
        ldx cf_method
        jsr same_sig
        bcs @satisfied
        lda cf_method
        ldx cf_name
        jsr conflicting
        bcs @conflict
        ldx cf_name
        lda #E_IFC_SIGNATURE_MISMATCH
        jsr iface_err
        bcc :+
        jmp @stop
:
        jmp @satisfied
@conflict:
        ldx cf_name
        lda #E_IFC_SIGNATURE_CONFLICT
        jsr iface_err
        bcc :+
        jmp @stop
:
        jmp @satisfied
@missing:
        ldx cf_name
        lda #E_IFC_METHOD_MISSING
        jsr iface_err
        bcc :+
        jmp @stop
:
@satisfied:
        inc cf_req
        dec cf_n
        jmp @req
@inext: inc cf_row
        inc cf_i
        jmp @impl
@cnext: inc cf_class
        beq @done
        jmp @class
@stop:  sec
        rts
@done:  clc
        rts

; A = class ID, X = method name ID. C=1 and Y=row when the class declares a
; method with that name; C=0 otherwise. A field with the name does not count.
find_method:
        sta fmc_class
        stx fmc_name
        ldy fmc_class
        lda #C_TYPE_MFIRST
        jsr tb_get
        sta fmc_row
        ldy fmc_class
        lda #C_TYPE_MCOUNT
        jsr tb_get
        sta fmc_n
@row:   lda fmc_n
        beq @no
        ldy fmc_row
        lda #C_MEM_FLAGS
        jsr tb_get
        and #MF_METHOD
        beq @next
        ldy fmc_row
        lda #C_MEM_NAME
        jsr tb_get
        cmp fmc_name
        beq @yes
@next:  inc fmc_row
        dec fmc_n
        bne @row
@no:    clc
        rts
@yes:   ldy fmc_row
        sec
        rts

; C=1 when the class method A matches a same-named requirement (X) of an
; implemented interface other than the one being checked. That means the
; interfaces themselves disagree, not that the class method is wrong.
conflicting:
        sta cn_method
        stx cn_name
        ldy cf_class
        lda #C_TYPE_IFIRST
        jsr tb_get
        sta cn_row
        ldy cf_class
        lda #C_TYPE_ICOUNT
        jsr tb_get
        sta cn_n
@iface: lda cn_n
        beq @no
        ldy cn_row
        lda #C_IMPL_IFACE
        jsr tb_get
        sta cn_iface
        cmp cf_iface
        beq @next_iface
        ldy cn_iface
        lda #C_TYPE_KIND
        jsr tb_get
        cmp #TYPE_INTERFACE
        bne @next_iface
        ldy cn_iface
        lda #C_TYPE_MFIRST
        jsr tb_get
        sta cn_req
        ldy cn_iface
        lda #C_TYPE_MCOUNT
        jsr tb_get
        sta cn_req_n
@req:   lda cn_req_n
        beq @next_iface
        ldy cn_req
        lda #C_MEM_NAME
        jsr tb_get
        cmp cn_name
        bne @next_req
        lda cn_method
        ldx cn_req
        jsr same_sig
        bcs @yes
@next_req:
        inc cn_req
        dec cn_req_n
        bne @req
@next_iface:
        inc cn_row
        dec cn_n
        bne @iface
@no:    clc
        rts
@yes:   sec
        rts

; C=1 when member rows A and X have equal signatures: result type, parameter
; count, and each parameter type.
same_sig:
        sta sg_a
        stx sg_b
        ldy sg_a
        lda #C_MEM_PCOUNT
        jsr tb_get
        sta sg_n
        ldy sg_b
        lda #C_MEM_PCOUNT
        jsr tb_get
        cmp sg_n
        bne @no
        lda sg_a
        ldx sg_b
        jsr same_result
        bcc @no
        ldy sg_a
        lda #C_MEM_PFIRST
        jsr tb_get
        sta sg_pa
        ldy sg_b
        lda #C_MEM_PFIRST
        jsr tb_get
        sta sg_pb
        lda #$00
        sta sg_i
@param: lda sg_i
        cmp sg_n
        beq @yes
        lda sg_pa
        clc
        adc sg_i
        sta sg_ra
        lda sg_pb
        clc
        adc sg_i
        sta sg_rb
        lda sg_ra
        ldx sg_rb
        jsr same_param
        bcc @no
        inc sg_i
        bne @param
@yes:   sec
        rts
@no:    clc
        rts

same_result:
        ldy #C_MEM_TBASE
        jmp same_cells

same_param:
        ldy #C_PAR_TBASE
        jmp same_cells

; C=1 when four consecutive type columns starting at Y are equal for rows A
; and X (base, name, length lo, length hi).
same_cells:
        sta sg_a
        stx sg_b
        sty sg_col
        lda #$00
        sta sg_ci
@col:   ldy sg_a
        lda sg_col
        clc
        adc sg_ci
        jsr tb_get
        sta sg_v
        ldy sg_b
        lda sg_col
        clc
        adc sg_ci
        jsr tb_get
        cmp sg_v
        bne @no
        inc sg_ci
        lda sg_ci
        cmp #$04
        bne @col
        sec
        rts
@no:    clc
        rts

; Report A at class cf_class's declaration line, column 1, with name X as
; argument 1. C=1 when the diagnostic limit stopped compilation.
iface_err:
        sta ie_code
        stx ie_name
        ldy cf_class
        lda #C_TYPE_LINE_LO
        jsr tb_get
        sta diag_line
        ldy cf_class
        lda #C_TYPE_LINE_HI
        jsr tb_get
        sta diag_line+1
        lda #$01
        sta diag_col
        lda ie_name
        jsr name_get
        lda #<name_out
        sta diag_arg1
        lda #>name_out
        sta diag_arg1+1
        lda name_out_len
        sta diag_arg1_len
        lda ie_code
        jsr diag_report
        bcc @ok
        sec
        rts
@ok:    clc
        rts

.segment "BSS"
; slot assignment
as_id:          .res 1
as_row:         .res 1
as_n:           .res 1
as_slot:        .res 1
; conformance
cf_class:       .res 1
cf_iface:       .res 1
cf_count:       .res 1
cf_row:         .res 1
cf_i:           .res 1
cf_req:         .res 1
cf_n:           .res 1
cf_name:        .res 1
cf_method:      .res 1
fmc_class:      .res 1
fmc_name:       .res 1
fmc_row:        .res 1
fmc_n:          .res 1
cn_method:      .res 1
cn_name:        .res 1
cn_row:         .res 1
cn_n:           .res 1
cn_iface:       .res 1
cn_req:         .res 1
cn_req_n:       .res 1
sg_a:           .res 1
sg_b:           .res 1
sg_n:           .res 1
sg_i:           .res 1
sg_pa:          .res 1
sg_pb:          .res 1
sg_col:         .res 1
sg_ci:          .res 1
sg_v:           .res 1
sg_ra:          .res 1
sg_rb:          .res 1
ie_code:        .res 1
ie_name:        .res 1