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

; output.s - generated PRG and MAP writer (E04-S01).
;
; Container (D128):
;   PRG starts with the load address PRG_LOAD_ADDR, then ordered sections.
;   A gap before a section is filled with zero bytes. The MAP is PETSCII text:
;
;     NOVA128 MAP 1
;     ENTRY hhhh
;     SECTION name start size
;     CLASS name size destroy interface-count interface-directory
;
; API (all calls in the bank-0 compiler state):
;   out_begin    A/X = source name (bank 0), Y = length. Sets out_load and
;                out_entry first. Refuses an existing NAME.PRG or NAME.MAP
;                with OUT_ERR_EXISTS; no existing output is overwritten.
;   out_startup  Emits the BASIC 7 stub at $1C01 and the startup code at
;                $1C0D from src/runtime/startup.s.
;   out_section  A/X = section name, Y = length; out_start = start address.
;   out_byte     A = byte; requires an open section.
;   out_bytes    A/X = data, Y = count (0-255).
;   out_end_section
;   out_finish   Writes the MAP, closes both files, and returns C=0 on success.
;   out_class    A/X = class name, Y = length. Adds a deterministic CLASS
;                record from out_class_size/destroy/ifaces/ifdir. Class
;                records follow the SECTION lines in call order.
;   out_abort    Closes and scratches only files created by this run.
;
; Every failure sets out_err and returns C=1; the caller must call out_abort.
; DOS/KERNAL errors are OUT_ERR_DISK; the detailed DOS code is not retained.

.setcpu "6502"
.include "../common/c128.inc"
.include "../common/diskio.inc"
.include "../common/formats.inc"

.import dio_open_cmd, dio_open_in, dio_open_out, dio_read_status
.import dio_chkout, dio_putc, dio_clrchn, dio_close, dio_command, dio_dos_code
.import gen_stub, gen_startup, gen_startup_size

.export out_begin, out_startup, out_section, out_end_section
.export out_byte, out_bytes, out_finish, out_abort
.export out_class
.export out_class_size, out_class_destroy, out_class_ifaces, out_class_ifdir
.export out_load, out_entry, out_start, out_err

.segment "ZEROPAGE"
out_dst:        .res 2
out_srcp:       .res 2
out_rec_ptr:    .res 2

.segment "CODE"

; Build one name from out_base plus the suffix at out_srcp (out_suffix_len).
; out_dst is advanced to the end; out_name_len is the total length.
build_name:
        ldy #$00
@base:  cpy out_base_len
        beq @suffix
        lda out_base,y
        sta (out_dst),y
        iny
        bne @base
@suffix:
        sty out_tmp
        clc
        lda out_dst
        adc out_tmp
        sta out_dst
        bcc :+
        inc out_dst+1
:       ldy #$00
@sl:    cpy out_suffix_len
        beq @done
        lda (out_srcp),y
        sta (out_dst),y
        iny
        bne @sl
@done:  lda out_base_len
        clc
        adc out_suffix_len
        sta out_name_len
        rts

.macro MAKE_NAME dst, suffix, slen, lenvar
        lda #<dst
        sta out_dst
        lda #>dst
        sta out_dst+1
        lda #<suffix
        sta out_srcp
        lda #>suffix
        sta out_srcp+1
        lda #slen
        sta out_suffix_len
        jsr build_name
        lda out_name_len
        sta lenvar
.endmacro

; Append out_append_len bytes from out_srcp to out_dst.
append_bytes:
        ldy #$00
@loop:  cpy out_append_len
        beq @done
        lda (out_srcp),y
        sta (out_dst),y
        iny
        bne @loop
@done:  tya
        clc
        adc out_dst
        sta out_dst
        bcc :+
        inc out_dst+1
:       rts

; out_rec_ptr = out_sections + out_index * OUT_RECORD_SIZE.
set_rec_ptr:
        lda #<out_sections
        sta out_rec_ptr
        lda #>out_sections
        sta out_rec_ptr+1
        ldx out_index
        beq @done
@add:   clc
        lda out_rec_ptr
        adc #OUT_RECORD_SIZE
        sta out_rec_ptr
        bcc :+
        inc out_rec_ptr+1
:       dex
        bne @add
@done:  rts

; out_rec_ptr = out_classes + out_index * OUT_CLASS_RECORD_SIZE.
set_class_ptr:
        lda #<out_classes
        sta out_rec_ptr
        lda #>out_classes
        sta out_rec_ptr+1
        ldx out_index
        beq @done
@add:   clc
        lda out_rec_ptr
        adc #OUT_CLASS_RECORD_SIZE
        sta out_rec_ptr
        bcc :+
        inc out_rec_ptr+1
:       dex
        bne @add
@done:  rts

; Build and send "S0:name" on the command channel.
out_scratch:
        sta out_scratch_ptr
        stx out_scratch_ptr+1
        sty out_scratch_len
        lda #<out_cmd
        sta out_dst
        lda #>out_cmd
        sta out_dst+1
        lda #<scratch_prefix
        sta out_srcp
        lda #>scratch_prefix
        sta out_srcp+1
        lda #3
        sta out_append_len
        jsr append_bytes
        lda out_scratch_ptr
        sta out_srcp
        lda out_scratch_ptr+1
        sta out_srcp+1
        lda out_scratch_len
        sta out_append_len
        jsr append_bytes
        lda out_scratch_len
        clc
        adc #3
        sta out_cmd_len
        lda #<out_cmd
        ldx #>out_cmd
        ldy out_cmd_len
        jsr dio_command
        bcs @disk
        lda dio_dos_code
        cmp #20
        bcc @ok
        cmp #62                       ; already absent is harmless
        beq @ok
@disk:  lda #OUT_ERR_DISK
        sta out_err
        sec
        rts
@ok:    clc
        rts

; Test A/X name, length Y. C=1 if it exists (out_err=0) or the drive failed
; (out_err=OUT_ERR_DISK); C=0 if it does not exist.
out_exists:
        jsr dio_open_in
        bcs @disk
        jsr dio_read_status
        bcs @disk
        lda dio_dos_code
        cmp #62
        beq @absent
        cmp #20
        bcs @disk
        lda #DIO_LFN_IN
        jsr dio_close
        lda #OUT_OK
        sta out_err
        sec
        rts
@absent:
        lda #DIO_LFN_IN
        jsr dio_close
        lda #OUT_OK
        sta out_err
        clc
        rts
@disk:
        lda #DIO_LFN_IN
        jsr dio_close
        lda #OUT_ERR_DISK
        sta out_err
        sec
        rts

out_begin:
        sta out_srcp
        stx out_srcp+1
        sty out_name_len

        lda #$00
        sta out_count
        sta out_class_count
        sta out_in_section
        sta out_prg_created
        sta out_map_created
        sta out_cmd_open
        sta out_prg_is_open
        sta out_map_is_open
        sta out_err
        lda out_load
        sta out_current
        lda out_load+1
        sta out_current+1

        lda out_name_len
        sta out_base_len
        cmp #4
        bcc @base_ready
        ldy out_name_len
        dey
        lda (out_srcp),y
        cmp #'8'
        bne @base_ready
        dey
        lda (out_srcp),y
        and #$7F
        cmp #'N'
        bne @base_ready
        dey
        lda (out_srcp),y
        cmp #'.'
        bne @base_ready
        lda out_name_len
        sec
        sbc #3
        sta out_base_len
@base_ready:
        lda out_base_len
        bne @have_base
        jmp @bad_name
@have_base:
        cmp #13
        bcc @base_ok
        jmp @bad_name
@base_ok:
        ldy #$00
@copy:  cpy out_base_len
        beq @copied
        lda (out_srcp),y
        sta out_base,y
        iny
        bne @copy
@copied:
        MAKE_NAME out_prg_name, sfx_prg, 4, out_prg_len
        MAKE_NAME out_map_name, sfx_map, 4, out_map_len
        MAKE_NAME out_prg_open, sfx_prg_open, 8, out_prg_open_len
        MAKE_NAME out_map_open, sfx_map_open, 8, out_map_open_len
        MAKE_NAME out_prg_read, sfx_prg_read, 8, out_prg_read_len
        MAKE_NAME out_map_read, sfx_map_read, 8, out_map_read_len

        jsr dio_open_cmd
        bcc :+
        jmp @disk_fail
:
        lda #1
        sta out_cmd_open

        lda #<out_prg_read
        ldx #>out_prg_read
        ldy out_prg_read_len
        jsr out_exists
        bcc @check_map
        lda out_err
        bne @close_fail
        jmp @exists
@check_map:
        lda #<out_map_read
        ldx #>out_map_read
        ldy out_map_read_len
        jsr out_exists
        bcc @open_prg
        lda out_err
        bne @close_fail
        jmp @exists

@exists:
        lda #OUT_ERR_EXISTS
        sta out_err
        jmp @close_fail

@open_prg:
        lda #1
        sta out_prg_is_open
        sta out_prg_created
        lda #<out_prg_open
        ldx #>out_prg_open
        ldy out_prg_open_len
        jsr dio_open_out
        bcs @fail_created
        jsr dio_read_status
        bcs @fail_created
        lda dio_dos_code
        cmp #20
        bcs @fail_created
        ldx #DIO_LFN_ERR
        jsr dio_chkout
        bcs @fail_created
        lda out_load
        jsr out_put
        bcs @fail_created
        lda out_load+1
        jsr out_put
        bcs @fail_created
        lda out_load                 ; the header is not part of section 0
        sta out_current
        lda out_load+1
        sta out_current+1
        clc
        rts

@bad_name:
        lda #OUT_ERR_NAME
        sta out_err
        sec
        rts
@disk_fail:
        lda #OUT_ERR_DISK
        sta out_err
        sec
        rts
@close_fail:
        jsr out_close_cmd
        sec
        rts
@fail_created:
        lda #OUT_ERR_DISK
        sta out_err
        jsr out_cleanup
        sec
        rts

out_startup:
        lda #<PRG_LOAD_ADDR
        sta out_start
        lda #>PRG_LOAD_ADDR
        sta out_start+1
        lda #<stub_name
        ldx #>stub_name
        ldy #4
        jsr out_section
        bcs @out
        lda #<gen_stub
        ldx #>gen_stub
        ldy #PRG_STUB_SIZE
        jsr out_bytes
        bcs @out
        jsr out_end_section

        lda #<PRG_ENTRY_ADDR
        sta out_start
        lda #>PRG_ENTRY_ADDR
        sta out_start+1
        lda #<start_name
        ldx #>start_name
        ldy #5
        jsr out_section
        bcs @out
        lda #<gen_startup
        ldx #>gen_startup
        ldy #<gen_startup_size
        jsr out_bytes
        bcs @out
        jmp out_end_section
@out:   rts

out_section:
        sta out_tmp
        stx out_tmp+1
        sty out_tmp_len
        lda out_in_section
        beq @no_prev
        jsr out_end_section
@no_prev:
        lda out_count
        cmp #OUT_MAX_SECTIONS
        bcs @too_many
        lda out_tmp_len
        cmp #OUT_SECTION_NAME_MAX + 1
        bcs @bad_name
        lda out_count
        sta out_index
        jsr set_rec_ptr
        ldy #0
        lda out_tmp
        sta (out_rec_ptr),y
        iny
        lda out_tmp+1
        sta (out_rec_ptr),y
        iny
        lda out_tmp_len
        sta (out_rec_ptr),y
        iny
        lda out_start
        sta (out_rec_ptr),y
        iny
        lda out_start+1
        sta (out_rec_ptr),y
        iny
        lda #$00
        sta (out_rec_ptr),y
        iny
        sta (out_rec_ptr),y

        lda out_current+1
        cmp out_start+1
        bcc @pad
        bne @order
        lda out_current
        cmp out_start
        bcc @pad
        bne @order
        beq @at_start
@pad:   lda out_current+1
        cmp out_start+1
        bcc @pad_byte
        bne @at_start
        lda out_current
        cmp out_start
        bcs @at_start
@pad_byte:
        lda #$00
        jsr out_put
        bcs @out
        jmp @pad
@at_start:
        lda #1
        sta out_in_section
        inc out_count
        clc
        rts
@order:
        lda #OUT_ERR_ORDER
        sta out_err
        sec
        rts
@too_many:
        lda #OUT_ERR_SECTIONS
        sta out_err
        sec
        rts
@bad_name:
        lda #OUT_ERR_NAME
        sta out_err
        sec
@out:   rts

out_end_section:
        lda out_in_section
        beq @ok
        ldy #5
        lda out_current
        sec
        sbc out_start
        sta (out_rec_ptr),y
        iny
        lda out_current+1
        sbc out_start+1
        sta (out_rec_ptr),y
        lda #$00
        sta out_in_section
@ok:    clc
        rts

out_byte:
        sta out_byte_value
        lda out_in_section
        bne @write
        lda #OUT_ERR_STATE
        sta out_err
        sec
        rts
@write: lda out_byte_value
        jmp out_put

; A = byte, no section check. Preserves Y; C=1 on write failure.
out_put:
        sty out_y
        jsr dio_putc
        bcs @fail
        inc out_current
        bne @ok
        inc out_current+1
@ok:    ldy out_y
        clc
        rts
@fail:
        lda #OUT_ERR_DISK
        sta out_err
        ldy out_y
        sec
        rts

out_bytes:
        sta out_srcp
        stx out_srcp+1
        sty out_append_len
        ldy #$00
@loop:  cpy out_append_len
        beq @done
        lda (out_srcp),y
        sty out_y
        jsr out_byte
        bcs @out
        ldy out_y
        iny
        bne @loop
@done:  clc
@out:   rts

; A/X = class name, Y = length. The descriptor values are supplied in the
; exported out_class_* variables. C=1 sets out_err and adds no record.
out_class:
        sta out_tmp
        stx out_tmp+1
        sty out_tmp_len
        lda out_class_count
        cmp #OUT_MAX_CLASSES
        bcs @too_many
        lda out_tmp_len
        cmp #OUT_SECTION_NAME_MAX + 1
        bcs @bad_name
        lda out_class_count
        sta out_index
        jsr set_class_ptr
        ldy #0
        lda out_tmp
        sta (out_rec_ptr),y
        iny
        lda out_tmp+1
        sta (out_rec_ptr),y
        iny
        lda out_tmp_len
        sta (out_rec_ptr),y
        iny
        lda out_class_size
        sta (out_rec_ptr),y
        iny
        lda out_class_size+1
        sta (out_rec_ptr),y
        iny
        lda out_class_destroy
        sta (out_rec_ptr),y
        iny
        lda out_class_destroy+1
        sta (out_rec_ptr),y
        iny
        lda out_class_ifaces
        sta (out_rec_ptr),y
        iny
        lda out_class_ifdir
        sta (out_rec_ptr),y
        iny
        lda out_class_ifdir+1
        sta (out_rec_ptr),y
        inc out_class_count
        clc
        rts
@too_many:
        lda #OUT_ERR_CLASSES
        sta out_err
        sec
        rts
@bad_name:
        lda #OUT_ERR_NAME
        sta out_err
        sec
        rts

out_finish:
        jsr out_end_section
        jsr out_close_prg

        lda #1
        sta out_map_is_open
        sta out_map_created
        lda #<out_map_open
        ldx #>out_map_open
        ldy out_map_open_len
        jsr dio_open_out
        bcs @fail
        jsr dio_read_status
        bcs @fail
        lda dio_dos_code
        cmp #20
        bcs @fail
        ldx #DIO_LFN_ERR
        jsr dio_chkout
        bcs @fail
        jsr out_write_map
        bcs @fail
        jsr out_close_map
        jsr out_close_cmd
        lda #OUT_OK
        sta out_err
        lda #$00
        sta out_prg_created
        sta out_map_created
        clc
        rts
@fail:
        lda out_err
        bne :+
        lda #OUT_ERR_DISK
        sta out_err
:       jsr out_cleanup
        sec
        rts

out_abort:
        lda #OUT_OK
        sta out_err
        jsr out_cleanup
        lda out_err
        beq @ok
        sec
        rts
@ok:    clc
        rts

; Close created outputs and scratch only files this run created.
out_cleanup:
        jsr out_close_prg
        jsr out_close_map
        lda out_cmd_open
        bne @have_cmd
        jsr dio_open_cmd
        bcs @done
        lda #1
        sta out_cmd_open
@have_cmd:
        lda out_prg_created
        beq @map
        lda #<out_prg_name
        ldx #>out_prg_name
        ldy out_prg_len
        jsr out_scratch
@map:   lda out_map_created
        beq @close
        lda #<out_map_name
        ldx #>out_map_name
        ldy out_map_len
        jsr out_scratch
@close:
        jsr out_close_cmd
@done:
        lda #$00
        sta out_prg_created
        sta out_map_created
        rts

out_close_prg:
        lda out_prg_is_open
        beq @ok
        jsr dio_clrchn
        lda #DIO_LFN_ERR
        jsr dio_close
        lda #$00
        sta out_prg_is_open
@ok:    clc
        rts

out_close_map:
        lda out_map_is_open
        beq @ok
        jsr dio_clrchn
        lda #DIO_LFN_ERR
        jsr dio_close
        lda #$00
        sta out_map_is_open
@ok:    clc
        rts

out_close_cmd:
        lda out_cmd_open
        beq @ok
        lda #DIO_LFN_CMD
        jsr dio_close
        lda #$00
        sta out_cmd_open
@ok:    clc
        rts

; ---------------------------------------------------------------- MAP text
out_write_map:
        lda #<map_header
        ldx #>map_header
        ldy #map_header_len
        jsr out_text
        bcc :+
        jmp @out
:
        lda #<map_entry
        ldx #>map_entry
        ldy #map_entry_len
        jsr out_text
        bcc :+
        jmp @out
:
        lda out_entry
        sta out_num
        lda out_entry+1
        sta out_num+1
        jsr out_hex4
        bcc :+
        jmp @out
:
        jsr out_cr
        bcc :+
        jmp @out
:
        lda #$00
        sta out_index
@section:
        lda out_index
        cmp out_count
        beq @done
        jsr set_rec_ptr
        lda #<section_prefix
        ldx #>section_prefix
        ldy #section_prefix_len
        jsr out_text
        bcs @out
        ldy #0
        lda (out_rec_ptr),y
        sta out_srcp
        iny
        lda (out_rec_ptr),y
        sta out_srcp+1
        iny
        lda (out_rec_ptr),y
        sta out_text_len
        ldy #0
@name:  cpy out_text_len
        beq @named
        lda (out_srcp),y
        sty out_y
        jsr out_char
        bcs @out
        ldy out_y
        iny
        bne @name
@named:
        lda #' '
        jsr out_char
        bcs @out
        ldy #3
        lda (out_rec_ptr),y
        sta out_num
        iny
        lda (out_rec_ptr),y
        sta out_num+1
        jsr out_hex4
        bcs @out
        lda #' '
        jsr out_char
        bcs @out
        ldy #5
        lda (out_rec_ptr),y
        sta out_num
        iny
        lda (out_rec_ptr),y
        sta out_num+1
        jsr out_hex4
        bcs @out
        jsr out_cr
        bcs @out
        inc out_index
        jmp @section
@done:  jsr out_write_classes
        bcs @out
        clc
@out:   rts

; Write CLASS records after the SECTION records, in out_class call order.
out_write_classes:
        lda #$00
        sta out_index
@class:
        lda out_index
        cmp out_class_count
        bne @body
        jmp @done
@body:
        jsr set_class_ptr
        lda #<class_prefix
        ldx #>class_prefix
        ldy #class_prefix_len
        jsr out_text
        bcc @prefix_ok
        jmp @out
@prefix_ok:
        ldy #0
        lda (out_rec_ptr),y
        sta out_srcp
        iny
        lda (out_rec_ptr),y
        sta out_srcp+1
        iny
        lda (out_rec_ptr),y
        sta out_text_len
        ldy #0
@name:  cpy out_text_len
        beq @named
        lda (out_srcp),y
        sty out_y
        jsr out_char
        bcc @name_ok
        jmp @out
@name_ok:
        ldy out_y
        iny
        bne @name
@named:
        lda #' '
        jsr out_char
        bcc @space1
        jmp @out
@space1:
        ldy #3
        lda (out_rec_ptr),y
        sta out_num
        iny
        lda (out_rec_ptr),y
        sta out_num+1
        jsr out_hex4
        bcc @size_ok
        jmp @out
@size_ok:
        lda #' '
        jsr out_char
        bcc @space2
        jmp @out
@space2:
        ldy #5
        lda (out_rec_ptr),y
        sta out_num
        iny
        lda (out_rec_ptr),y
        sta out_num+1
        jsr out_hex4
        bcc @destroy_ok
        jmp @out
@destroy_ok:
        lda #' '
        jsr out_char
        bcc @space3
        jmp @out
@space3:
        ldy #7
        lda (out_rec_ptr),y
        jsr out_hex_byte
        bcc @count_ok
        jmp @out
@count_ok:
        lda #' '
        jsr out_char
        bcc @space4
        jmp @out
@space4:
        ldy #8
        lda (out_rec_ptr),y
        sta out_num
        iny
        lda (out_rec_ptr),y
        sta out_num+1
        jsr out_hex4
        bcc @dir_ok
        jmp @out
@dir_ok:
        jsr out_cr
        bcc @line_ok
        jmp @out
@line_ok:
        inc out_index
        jmp @class
@done:  clc
@out:   rts

; A/X = text, Y = length.
out_text:
        sta out_srcp
        stx out_srcp+1
        sty out_text_len
        ldy #$00
@loop:  cpy out_text_len
        beq @done
        lda (out_srcp),y
        sty out_y
        jsr out_char
        bcs @out
        ldy out_y
        iny
        bne @loop
@done:  clc
@out:   rts

out_cr:
        lda #$0D
        jmp out_char

out_char:
        sty out_y
        jsr dio_putc
        bcs @fail
        ldy out_y
        clc
        rts
@fail:
        lda #OUT_ERR_DISK
        sta out_err
        ldy out_y
        sec
        rts

out_hex4:
        lda out_num+1
        jsr out_hex_byte
        bcs @out
        lda out_num
        jmp out_hex_byte
@out:   rts

out_hex_byte:
        pha
        lsr a
        lsr a
        lsr a
        lsr a
        tax
        lda hex_digits,x
        jsr out_char
        bcs @fail
        pla
        and #$0F
        tax
        lda hex_digits,x
        jmp out_char
@fail:  pla
        sec
        rts

.segment "RODATA"
sfx_prg:        .byte ".PRG"
sfx_map:        .byte ".MAP"
sfx_prg_open:   .byte ".PRG,P,W"
sfx_map_open:   .byte ".MAP,S,W"
sfx_prg_read:   .byte ".PRG,P,R"
sfx_map_read:   .byte ".MAP,S,R"
stub_name:      .byte "STUB"
start_name:     .byte "START"
scratch_prefix: .byte "S0:"
map_header:     .byte "NOVA128 MAP 1", $0D
map_header_len = * - map_header
map_entry:      .byte "ENTRY "
map_entry_len = * - map_entry
section_prefix: .byte "SECTION "
section_prefix_len = * - section_prefix
class_prefix:   .byte "CLASS "
class_prefix_len = * - class_prefix
hex_digits:     .byte "0123456789ABCDEF"

.segment "BSS"
out_base:       .res 12
out_base_len:   .res 1
out_name_len:   .res 1
out_suffix_len: .res 1
out_prg_name:   .res 16
out_prg_len:    .res 1
out_map_name:   .res 16
out_map_len:    .res 1
out_prg_open:   .res 20
out_prg_open_len: .res 1
out_map_open:   .res 20
out_map_open_len: .res 1
out_prg_read:   .res 20
out_prg_read_len: .res 1
out_map_read:   .res 20
out_map_read_len: .res 1
out_cmd:        .res 48
out_cmd_len:    .res 1
out_load:       .res 2
out_entry:      .res 2
out_start:      .res 2
out_current:    .res 2
out_count:      .res 1
out_class_count: .res 1
out_index:      .res 1
out_in_section: .res 1
out_prg_created: .res 1
out_map_created: .res 1
out_cmd_open:   .res 1
out_prg_is_open: .res 1
out_map_is_open: .res 1
out_err:        .res 1
out_sections:   .res OUT_MAX_SECTIONS * OUT_RECORD_SIZE
out_classes:    .res OUT_MAX_CLASSES * OUT_CLASS_RECORD_SIZE
out_class_size: .res 2
out_class_destroy: .res 2
out_class_ifaces: .res 1
out_class_ifdir: .res 2
out_tmp:        .res 2
out_tmp_len:    .res 1
out_scratch_ptr: .res 2
out_scratch_len: .res 1
out_append_len: .res 1
out_byte_value: .res 1
out_text_len:   .res 1
out_y:          .res 1
out_num:        .res 2