.export parser_start, parser_error, parser_skipws, parser_emit_byte, parser_inc_opos

; Parser state

.exportzp bptr, bpos, bmax, linenum, buf_ptr

.exportzp loop_sp, var_sp

; Output state

.exportzp opos

; From actions.asm

.importzp VT_WORD, VT_STRING, VT_FLOAT, VT_UNDEF

.importzp VT_ARRAY_WORD, VT_ARRAY_BYTE, VT_ARRAY_STRING, VT_ARRAY_FLOAT

.importzp LT_PROC_DATA, LT_PROC_2, LT_DO_LOOP, LT_REPEAT, LT_WHILE_1

.importzp LT_WHILE_2, LT_FOR_1,LT_FOR_2, LT_EXIT, LT_IF, LT_ELSE, LT_ELIF

; From alloc.asm

.import alloc_prog

.importzp prog_ptr, end_ptr, BASIC_TOP

; From vars.asm

.exportzp var_count, label_count

; From runtime.asm

.importzp IOCHN, COLOR, IOERROR, PRINT_COLOR, PRINT_RTAB_ARG

.import putc

; From interpreter.asm

.importzp DEGFLAG, DEGFLAG_DEG, DEGFLAG_RAD, saved_cpu_stack

.import EXE_END, PMGMODE, PMGBASE

; Interpreted commands

.import CLEAR_DATA, SOUND_OFF

; From errors.asm

.import error_msg_list

.importzp ERR_PARSE, ERR_NO_ELOOP, ERR_LABEL, ERR_TOO_LONG

.segment "IDEZP": zeropage

buf_ptr:.res 2

bmax: .res 1

pptr: .res 2

opos: .res 1

linenum: .res 2

loop_sp: .res 1

var_sp: .res 1

label_count: .res 1

var_count: .res 1

.code

.include "atari.inc"

bptr = INBUFF

bpos = CIX

INTLBUF = $DA51

SKBLANK = $DBA1

parser_skipws = SKBLANK

SM_EXIT = 0

SM_RET = 1

SM_ERET = 2

SM_EMIT_1= 3

SM_EMIT_2= 4

SM_EMIT_3= 5

SM_EMIT_4= 6

SM_EMIT_5= 7

SM_EMIT_6= 8

SM_EMIT_7= 9

SM_EMIT_8= 10

SM_EMIT_9= 11

SM_EMIT_10= 12

SM_EMIT_11= 13

SM_EMIT_12= 14

SM_EMIT_13= 15

SM_EMIT_14= 16

SM_EMIT_15= 17

SM_EMIT_16= 18

SM_EMIT_17= 19

SM_EMIT_18= 20

SM_EMIT_19= 21

SM_EMIT_20= 22

SM_EMIT_21= 23

SM_EMIT_22= 24

SM_EMIT_23= 25

SM_EMIT_24= 26

SM_EMIT_25= 27

SM_EMIT_26= 28

SM_EMIT_27= 29

SM_EMIT_28= 30

SM_EMIT_N= SM_EMIT_28 + 1

.include "basic.inc"

.include "basic.asm"

.code

.importzp laddr_ptr, laddr_buf

lda (laddr_buf), y

beq parser_error ; unresolved label, return with Y=1 : ERR_LABEL

; Note: C = 0 from above!

lda laddr_buf

adc #4

sta laddr_buf

bcc :+

inc laddr_buf+1

:

ldy #1

.assert ERR_LABEL = 1, error, "Parser depends on ERR_LABEL = 1"

lda laddr_buf

cmp laddr_ptr

lda laddr_buf+1

sbc laddr_ptr+1

bne lbl_chk_nxt

; Check if parser stack is empty

ldy #ERR_NO_ELOOP

lda loop_sp

bne parser_error

;lda #TOK_END ; Already A=0 from above

.assert TOK_END = 0, error, "Parser depends on TOK_END = 0"

clc

bcc emit_const ; Exit after emit

.proc parser_fetch

inc pptr

bne :+

inc pptr+1

: ldy #0

lda (pptr),y

::rts1: rts

jsr parser_fetch

ldy opos

sta (prog_ptr),y

inc opos

bne rts1

ldy #ERR_TOO_LONG

; Fall through

.proc parser_error

; Prints error message in Y

; Message is stored shifted, and bit 0 set for the last byte

ploop: lda error_msg_list, y

iny

lsr ; Restore character, shift end bit to C

php ; Save C

jsr putc

plp ; Restore C

bcc ploop

; C is set at end, signaling error

; Exit restoring stack, allowing calls from depth into the parser

jmp EXE_END

tsx

stx saved_cpu_stack

lda #0

ldx #zp_clear_end - zp_clear_start

sta zp_clear_start, x

dex

bpl zp_clear

ldx #0

stx bpos

stx bmax

lda buf_ptr

cmp end_ptr

lda buf_ptr+1

sbc end_ptr+1

bcs parse_eof

; Reads a line

inc linenum

bne :+

inc linenum+1

:

.proc ucase_line

; Point parsing buffer pointer to line buffer

jsr INTLBUF

; Convert to uppercase and copy to line buffer

;ldx #0 ; X is 0 from above, assume INTLBUF does not overwrite X.

ldy #$FF

iny

lda (buf_ptr), y

sta (bptr), y

cmp #$9B

beq ucase_end ; End upper-casing, C=1

cmp #'"'

bne skip_str ; Skip string constants

txa

eor #1

tax

cpx #1

beq loop

sbc #'a'-1

cmp #'z'-'a'+1

bcs loop

adc #'A'

bcc loop_redo

; C=1 always from above

; Point buf_ptr to next line

tya

adc buf_ptr

sta buf_ptr

bcc :+

inc buf_ptr+1

:

lda #0

; Parse statement, A=0 on input

ldx #<(PARSE_START-1)

ldy #>(PARSE_START-1)

; Parser sub

pha

lda pptr

pha

stx pptr

sty pptr+1

tsx

cpx #16

bcc too_long

; Always skip WS at start of new token

jsr parser_skipws

; Process one line of the parser definition

; Store input and output position

lda bpos

pha

lda opos

pha

; Parser loop

; Read next parser instruction

jsr parser_fetch

bmi pcall

cmp #SM_EMIT_N

tax

bcs match_char

.assert SM_EXIT = 0, error, "SM_EXIT must be 0"

beq pexit_err

dex

.assert SM_RET = 1, error, "SM_RET must be 1"

beq pexit_ok

dex

.assert SM_ERET = 2, error, "SM_ERET must be 2"

beq pemit_ret

.assert SM_EMIT_1 = 3, error, "SM_EMIT_1 must be 3"

: jsr emit_sub

dex

bne :-

beq ploop

; Character match

ldy bpos

cmp #'a'

bcc match

lda #'.'

cmp (bptr),y

beq matched_dot

txa

eor #32 ; To uppercase

cmp (bptr),y

bne ploop_nextline

inc bpos

bne ploop

asl

tay

lda SM_TABLE_ADDR+1,y

ldx SM_TABLE_ADDR,y

cpy #(2*(SMB_STATE_START-128))

bcc pcall_ml

tay

lda pptr+1

bcs parser_sub ; Jump always

jsr emit_sub

pla

pla

pla

sta pptr

pla

sta pptr+1

bne ploop

; Parser returned, alloc program space

jsr alloc_prog

; Check if we are at end of line

ldy bpos

inc bpos

lda (bptr), y

eor #':' ; Colon: continue parsing line

beq parse_start ; jump with A=0

; Current syntax file always checks for EOL at the end of parsing,

; no need to check here

; End parsing of current line, jump with A=0

jmp parse_line

; Calls a machine-language subroutine

; NOTE: we always call ML subs with carry clear (C=0)

jsr call_ax1

bcc ploop

bcs ploop_nextline

; Matched a dot (abbreviated statement), skips over all remaining chars

iny

sty bpos

jsr parser_fetch

bmi ploop_nofetch

cmp #SM_EMIT_N

bcs skip_chars

bcc ploop_tax

pha

txa

pha

rts

pla

; sta opos ; // Ignored

pla

; sta bpos ; // Ignored

pla

sta pptr

pla

beq set_parse_error

sta pptr+1

; fall through

; Match failed, save position, unroll and go to next line or exit

ldy bpos

cpy bmax

bcc :+

sty bmax

:

pla

sta opos

pla

sta bpos

ldy #0

iny

lda (pptr),y

cmp #SM_EMIT_N ; Note: comparisons sorted for faster skip

bcs skip_nextline

tax

dex

.assert SM_RET = 1, error, "SM_RET must be 1"

beq go_ploop

dex

.assert SM_ERET = 2, error, "SM_ERET must be 2"

beq skip_ret

.assert SM_EMIT_1 = 3, error, "SM_EMIT_1 must be 3"

: iny ; Skip token

dex

bne :-

beq skip_nextline

iny ; Skip token and RET

tya

; clc ; C is 0 from above

adc pptr

sta pptr

bcc :+

inc pptr+1

: jmp ploop_line

ldy #ERR_PARSE

jmp parser_error