;
; Global constants
;
const FALSE = 0
const TRUE	= -1
;
; Hardware constants
;
const csw           = $0036
const speaker       = $C030
const showgraphics  = $C050
const showtext      = $C051
const showfull      = $C052
const showmix       = $C053
const showpage1     = $C054
const showpage2     = $C055
const showlores     = $C056
const showhires     = $C057
const pushbttn1     = $C061
const pushbttn2     = $C062
const pushbttn3     = $C063
const keyboard      = $C000
const keystrobe     = $C010
const keyenter      = $8D
const keyspace      = $A0
const keyarrowup    = $8B
const keyarrowdown  = $8A
const keyarrowleft  = $88
const keyarrowright = $95
const keyescape     = $9B
const keyctrla      = $81
const keyctrlb      = $82
const keyctrlc      = $83
const keyctrld      = $84
const keyctrle      = $85
const keyctrli      = $89
const keyctrlk      = $8B
const keyctrll      = $8C
const keyctrln      = $8E
const keyctrlo      = $8F
const keyctrlp      = $90
const keyctrlq      = $91
const keyctrlr      = $92
const keyctrls      = $93
const keyctrlt      = $94
const keyctrlu      = $95
const keyctrlv      = $96
const keyctrlw      = $97
const keyctrlx      = $98
const keyctrlz      = $9A
const keydelete     = $FF
const getbuff       = $01FF
const argbuff       = $2006
word txtscrn[]      = $0400,$0480,$0500,$0580,$0600,$0680,$0700,$0780
word                = $0428,$04A8,$0528,$05A8,$0628,$06A8,$0728,$07A8
word                = $0450,$04D0,$0550,$05D0,$0650,$06D0,$0750,$07D0
;
; Data and text buffer constants
;
const machid        = $BF98
const maxlines      = 626
const maxfill       = 640
const iobuffer      = $0800
const databuff      = $0C00
const strlinbuf     = $1000
const strheapmap    = $1500
const strheapmsz    = $70 ; = memory@16 bytes per bit map, 128 bytes per 8 bit map, 1K bytes per 8 byte map
const maxlnlen      = 79
const strheap       = $7000
const strheasz      = $3800
const codebuff      = $A800
const codebuffsz    = $1000
const pgjmp         = 16
const changed       = 1
const insmode       = 2
const showcurs      = 4
const uppercase     = 8
const shiftlock     = 128
;
; Editor variables
;
byte nullstr[]      = ""
byte version[]      = "PLASMA VERSION 0.3 "
byte errorstr[]     = "ERROR: $"
byte okstr[]        = "OK"
byte perr
byte outofmem[]     = "OUT OF MEMORY!"
byte losechng[]     = "LOSE CHANGES TO FILE (Y/N)?"
;byte emiterr[]      = "EMIT CODE/DATA MISMATCH"
byte untitled[]     = "UNTITLED"
byte txtfile[64]    = "UNTITLED.PLA"
byte flags          = 0
byte flash          = 0
byte cursx, cursy, scrnleft, curscol, underchr, curschr
word cursrow, scrntop, cursptr
word numlines       = 0
word cutbuf         = 0
word keyin
;
; Predeclared functions
;
func cmdmode
;
; Compiler variables
;
;
; Tokens
;
const ID_TKN						= $D6 ; V
const CHR_TKN						= $C3 ; C
const INT_TKN						= $C9 ; I
const STR_TKN						= $D3 ; S
const EOL_TKN						= $02
const EOF_TKN						= $01
const ERR_TKN					    = $00
;
; Binary operand operators
;
const SET_TKN						= $BD ; =
const ADD_TKN						= $AB ; +
const SUB_TKN						= $AD ; -
const MUL_TKN						= $AA ; *
const DIV_TKN						= $AF ; /
const MOD_TKN						= $A5 ; %
const OR_TKN						= $BF ; ?
const EOR_TKN						= $DE ; ^
const AND_TKN						= $A6 ; &
const SHR_TKN						= $D2 ; R
const SHL_TKN						= $CC ; L
const GT_TKN						= $BE ; >
const GE_TKN						= $C8 ; H
const LT_TKN						= $BC ; <
const LE_TKN						= $C2 ; B
const NE_TKN						= $D5 ; U
const EQ_TKN						= $C5 ; E
const LOGIC_AND_TKN			        = $CE ; N
const LOGIC_OR_TKN			        = $CF ; O
;
; Unary operand operators
;
const AT_TKN						= $C0 ; @
const DOT_TKN						= $AE ; .
const COLON_TKN					    = $BA ; :
const NEG_TKN						= $AD ; -
const COMP_TKN					    = $A3 ; #
const LOGIC_NOT_TKN			        = $A1 ; !
const BPTR_TKN					    = $DE ; ^
const WPTR_TKN					    = $AA ; *
const INC_TKN						= $C1 ; A
const DEC_TKN						= $C4 ; D
;
; Enclosure tokens
;
const OPEN_PAREN_TKN		        = $A8 ; (
const CLOSE_PAREN_TKN		        = $A9 ; )
const OPEN_BRACKET_TKN	            = $DB ; [
const CLOSE_BRACKET_TKN             = $DD ; ]
;
; Misc. tokens
;
const COMMA_TKN					    = $AC ; ,
const COMMENT_TKN				    = $BB ; ;
;
; Keyword tokens
;
const CONST_TKN					    = $80
const BYTE_TKN					    = $81
const WORD_TKN					    = $82
const IF_TKN					    = $83
const ELSEIF_TKN			    	= $84
const ELSE_TKN				    	= $85
const FIN_TKN				    	= $86
const END_TKN				    	= $87
const WHILE_TKN				    	= $88
const LOOP_TKN				    	= $89
const CASE_TKN				    	= $8A
const OF_TKN				    	= $8B
const DEFAULT_TKN			    	= $8C
const ENDCASE_TKN			    	= $8D
const FOR_TKN				    	= $8E
const TO_TKN				    	= $8F
const DOWNTO_TKN			    	= $90
const STEP_TKN				    	= $91
const NEXT_TKN				    	= $92
const REPEAT_TKN			    	= $93
const UNTIL_TKN				    	= $94
const IFUNC_TKN				    	= $95
const TFUNC_TKN				    	= $96
const NFUNC_TKN				    	= $97
const DONE_TKN				    	= $98
const RETURN_TKN			    	= $99
const BREAK_TKN				    	= $9A
const START_TKN				    	= $9B
const EXIT_TKN				    	= $9C
const EVAL_TKN				    	= $9D
const FUNC_TKN				    	= $9E
;
; Types
;
const CONST_TYPE				    = $01
const BYTE_TYPE					    = $02
const WORD_TYPE					    = $04
const VAR_TYPE					    = $06 ; (WORD_TYPE | BYTE_TYPE)
const FUNC_TYPE					    = $08
const FUNC_CONST_TYPE               = $09
const ADDR_TYPE					    = $0E ; (VAR_TYPE | FUNC_TYPE)
const LOCAL_TYPE				    = $10
const BPTR_TYPE					    = $20
const WPTR_TYPE					    = $40
const PTR_TYPE					    = $60 ; (BPTR_TYPE | WPTR_TYPE)
const XBYTE_TYPE                    = $22 ; (BPTR_TYPE | BYTE_TYPE)
const XWORD_TYPE                    = $44 ; (WPTR_TYPE | WORD_TYPE)
const STR_TYPE				    	= $80
;
; Keywords
;
byte keywrds[]
byte					 = "IF",	 IF_TKN
byte					 = "TO",    TO_TKN
byte					 = "IS",	 OF_TKN
byte					 = "OR",	 LOGIC_OR_TKN
byte					 = "FOR",	 FOR_TKN
byte					 = "FIN",	 FIN_TKN
byte					 = "DEF",	 IFUNC_TKN
byte					 = "END",	 END_TKN
byte					 = "AND",	 LOGIC_AND_TKN
byte					 = "NOT",	 LOGIC_NOT_TKN
byte					 = "BYTE",	 BYTE_TKN
byte					 = "WORD",	 WORD_TKN
byte					 = "DEFT",	 TFUNC_TKN
byte					 = "DEFN",	 NFUNC_TKN
byte					 = "ELSE",	 ELSE_TKN
byte					 = "NEXT",	 NEXT_TKN
byte					 = "WHEN",	 CASE_TKN
byte					 = "LOOP",	 LOOP_TKN
byte                     = "FUNC",  FUNC_TKN
byte					 = "STEP",	 STEP_TKN
byte					 = "EXIT",	 EXIT_TKN
byte					 = "DONE",	 DONE_TKN
byte					 = "WEND",  ENDCASE_TKN
byte					 = "CONST", CONST_TKN
byte					 = "ELSIF", ELSEIF_TKN
byte					 = "WHILE", WHILE_TKN
byte					 = "UNTIL", UNTIL_TKN
byte					 = "BREAK", BREAK_TKN
byte					 = "OTHER", DEFAULT_TKN
byte					 = "DOWNTO",DOWNTO_TKN
byte					 = "REPEAT",REPEAT_TKN
byte					 = "RETURN",RETURN_TKN
byte					 = $FF
;
; Mathematical ops
;
const bops_tblsz = 17 ; minus 1
byte bops_tbl[] ; Highest precedence
byte					= MUL_TKN, DIV_TKN, MOD_TKN
byte					= ADD_TKN, SUB_TKN
byte					= SHR_TKN, SHL_TKN
byte					= AND_TKN
byte					= EOR_TKN
byte					= OR_TKN
byte					= GT_TKN, GE_TKN, LT_TKN, LE_TKN
byte					= EQ_TKN, NE_TKN
byte					= LOGIC_AND_TKN
byte					= LOGIC_OR_TKN
						; Lowest precedence
byte bops_prec[] ; Highest precedence
byte					= 1, 1, 1
byte					= 2, 2
byte					= 3, 3
byte					= 4
byte					= 5
byte					= 6
byte					= 7, 7, 7, 7
byte					= 8, 8
byte					= 9
byte					= 10
								 ; Lowest precedence
byte opstack[16]
byte precstack[16]
word opsp = -1
;
; Symbol table variables
;
const idglobal_tblsz    = 2048
const idlocal_tblsz	    = 512
const idglobal_tbl      = $1600
const idlocal_tbl       = $1E00
const ctag_max          = 640
const ctag_value        = $800
const ctag_flags        = $D80
const idval			    = 0
const idtype		    = 2
const idname		    = 3
const idrecsz		    = 4
word globals		    = 0
word datasize		    = 0
word lastglobal
byte locals			    = 0
word framesize	        = 0
word lastlocal
const resolved          = 1
const is_ctag           = $8000
const mask_ctag         = $7FFF
word codetag		    = -1
word codeptr, entrypoint = 0
byte lastop             = $FF
;
; Scanner variables
;
const inbuff = $0200
const instr  = $01FF
byte  token, tknlen
byte  parserrpos, parserr = 0
word  scanptr, tknptr, parserrln
word  constval
word  lineno = 0
;
; Compiler output messages
;
byte entrypt_str[]          = "START: "
byte comp_ok_msg[]		    = "COMPILATION COMPLETE"
byte dup_id[]		     	= "DUPLICATE IDENTIFIER"
byte undecl_id[]			= "UNDECLARED IDENTIFIER"
byte bad_cnst[]	  			= "BAD CONSTANT"
byte bad_offset[]			= "BAD STRUCT OFFSET"
byte bad_decl[]	            = "BAD DECLARATION"
byte bad_op[]				= "BAD OPERATION"
byte bad_stmnt[]			= "BAD STATMENT"
byte bad_expr[]				= "BAD EXPRESSION"
byte bad_syntax[]			= "BAD SYNTAX"
byte estk_overflw[]			= "EVAL STACK OVERFLOW"
byte estk_underflw[]		= "EVAL STACK UNDERFLOW"
byte local_overflw[]		= "LOCAL FRAME OVERFLOW"
byte global_sym_overflw[]   = "GLOBAL SYMBOL TABLE OVERFLOW"
byte local_sym_overflw[]	= "LOCAL SYMBOL TABLE OVERFLOW"
byte ctag_full[]            = "CODE LABEL OVERFLOW"
byte no_close_paren[]		= "MISSING CLOSING PAREN"
byte no_close_bracket[]		= "MISSING CLOSING BRACKET"
byte missing_op[]			= "MISSING OPERAND"
byte no_fin[]				= "MISSING FIN"
byte no_loop[]				= "MISSING LOOP"
byte no_until[]				= "MISSING UNTIL"
byte no_done[]				= "MISSING DONE"
byte no_local_init[]		= "NO INITIALIZED LOCALS"
;
; Runtime functions
;
byte runtime0[] = "romcall"
byte RUNTIME0[] = "ROMCALL"
byte runtime1[] = "syscall"
byte RUNTIME1[] = "SYSCALL"
byte runtime2[] = "memset"
byte RUNTIME2[] = "MEMSET"
byte runtime3[] = "memcpy"
byte RUNTIME3[] = "MEMCPY"
byte runtime4[] = "cout"
byte RUNTIME4[] = "COUT"
byte runtime5[] = "cin"
byte RUNTIME5[] = "CIN"
byte runtime6[] = "prstr"
byte RUNTIME6[] = "PRSTR"
byte runtime7[] = "rdstr"
byte RUNTIME7[] = "RDSTR"
;
; Parser variables
;
byte infunc		    = 0
byte stack_loop	    = 0
byte prevstmnt	    = 0
word retfunc_tag    = 0
word break_tag	    = 0
func parse_expr, parse_module
;
; ProDOS routines
;
def getpfx(path)
    byte params[3]

    ^path    = 0
    params.0 = 1
    params:1 = path
    perr     = syscall($C7, @params)
    return path
end
def setpfx(path)
    byte params[3]

    params.0 = 1
    params:1 = path
    perr     = syscall($C6, @params)
    return path
end
def open(path, buff)
    byte params[6]

    params.0 = 3
    params:1 = path
    params:3 = buff
    perr     = syscall($C8, @params)
    return params.5
end
def close(refnum)
    byte params[2]

    params.0 = 1
    params.1 = refnum
    perr     = syscall($CC, @params)
    return perr
end
def read(refnum, buff, len)
    byte params[8]

    params.0 = 4
    params.1 = refnum
    params:2 = buff
    params:4 = len
    params:6 = 0
    perr     = syscall($CA, @params)
    return params:6
end
def write(refnum, buff, len)
    byte params[8]

    params.0 = 4
    params.1 = refnum
    params:2 = buff
    params:4 = len
    params:6 = 0
    perr     = syscall($CB, @params)
    return params:6
end
def create(path, access, type, aux)
    byte params[12]

    params.0  = 7
    params:1  = path
    params.3  = access
    params.4  = type
    params:5  = aux
    params.7  = $1
    params:8  = 0
    params:10 = 0
    perr      = syscall($C0, @params)
    return perr
end
def destroy(path)
    byte params[12]

    params.0 = 1
    params:1 = path
    perr     = syscall($C1, @params)
    return perr
end
def newline(refnum, emask, nlchar)
    byte params[4]

    params.0 = 3
    params.1 = refnum
    params.2 = emask
    params.3 = nlchar
    perr     = syscall($C9, @params)
    return perr
end

;=====================================
;
;            Editor
;
;=====================================

def crout
    return cout ($0D)
end
def bell
    return romcall(0, 0, 0, 0, $FBDD)
end
;
; Memory management routines
;
def strcpy(srcstr, dststr)
    byte strlen

    strlen = ^srcstr
    while (srcstr).[strlen] == $8D or (srcstr).[strlen] == $A0
        strlen = strlen - 1
    loop
    ^dststr = strlen
    return memcpy(srcstr + 1, dststr + 1, strlen)
end
def heapaddr(ofst, mask)
    word addr

    addr = (ofst << 7) + strheap
    while !(mask & 1)
        addr = addr + 16
        mask = mask >> 1
    loop
    return addr
end
def sizemask(size)
    if size <= 16
        return $01
    elsif size <= 32
        return $03
    elsif size <= 48
        return $07
    elsif size <= 64
        return $0F
    elsif size <= 80
        return $1F
    fin
end
deft heapalloc(size)
    byte szmask, i
    word mapmask

    szmask = sizemask(size)
    for i = strheapmsz - 1 downto 0
        if strheapmap.[i] <> $FF
            mapmask = szmask
            repeat
                if strheapmap.[i] & mapmask
                    mapmask = mapmask << 1
                else
                    strheapmap.[i] = strheapmap.[i] ? mapmask
                    return heapaddr(i, mapmask)
                fin
            until mapmask & $100
        fin
    next
    bell
    prstr(@outofmem)
end
def freestr(strptr)
    byte mask, ofst

    if strptr and strptr <> @nullstr
        mask = sizemask(^strptr + 1)
        ofst = (strptr - strheap) >> 4
        mask = mask << (ofst & $07)
        ofst = ofst >> 3
        strheapmap.[ofst] = strheapmap.[ofst] & #mask
    fin
end
def newstr(strptr)
    byte strlen
    word newptr

    strlen = ^strptr
    while (strptr).[strlen] == $8D or (strptr).[strlen] == $A0
        strlen = strlen - 1
    loop
    if strlen == 0
        return @nullstr
    fin
    newptr = heapalloc(strlen + 1)
    if newptr
        memcpy(strptr, newptr, strlen + 1)
        ^newptr = strlen
        return newptr
    fin
    return @nullstr
end
def inittxtbuf
    word i

    memset(0, strheapmap, strheapmsz)
    memset(@nullstr, strlinbuf, maxfill * 2)
    entrypoint = 0
    numlines   = 0
    cursrow    = 0
    curscol    = 0
    cursx      = 0
    cursy      = 0
    scrnleft   = 0
    scrntop    = 0
    cutbuf     = 0
end
;
; Case conversion/printing routines
;
def caseconv(chr)
    if flags & uppercase
        if chr & $E0 == $E0
            chr = chr - $E0
        fin
    fin
    return chr
end
def strupper(strptr)
    byte i, chr

    for i = ^strptr downto 1
        chr = (strptr).[i]
        if chr & $E0 == $E0
            (strptr).[i] = chr - $E0
        fin
    next
end
def strlower(strptr)
    byte i, chr

    for i = ^strptr downto 1
        chr = (strptr).[i]
        if chr & $E0 == $00
            (strptr).[i] = chr + $E0
        fin
    next
end
def txtupper
    word i, strptr

    flags = flags ? uppercase
    for i = numlines - 1 downto 0
        strupper(strlinbuf:[i])
    next
end
def txtlower
    word i, strptr

    flags = flags & #uppercase
    for i = numlines - 1 downto 0
        strlower(strlinbuf:[i])
    next
end
def prbyte(h)
	cout('$')
	romcall(h, 0, 0, 0, $FDDA)
end
def prword(h)
	cout('$')
	romcall(h >> 8, h, 0, 0, $F941)
end
def print(i)
	byte numstr[7]
	byte place, sign

	place = 6
	if i < 0
		sign = 1
		i    = -i
	else
		sign = 0
	fin
	while i >= 10
		numstr[place] = i % 10 + '0'
		i             = i / 10
		place         = place - 1
	loop
	numstr[place] = i + '0'
	place         = place - 1
	if sign
		numstr[place] = '-'
		place         = place - 1
	fin
	numstr[place] = 6 - place
	prstr(@numstr[place])
end
def nametostr(namestr, len, strptr)
	^strptr = len
	memcpy(namestr, strptr + 1, len)
end
;def toupper(c)
;	if c >= 'a'
;		if c <= 'z'
;			return c - $20
;		fin
;	fin
;	return c
;end
asm toupper
        LDA     ESTKL,X
        CMP     #'a'
        BCC     :+
        CMP     #'z'+1
        BCS     :+
        SEC
        SBC     #$20
        STA     ESTKL,X
:       RTS
end
asm clrhibit(strptr)
        LDY     #$02        ; strptr
        LDA     (FP),Y
        STA     TMPL
        INY
        LDA     (FP),Y
        STA     TMPH
        LDY     #$00
        LDA     (TMP),Y
        BEQ     :+
        TAY
CLHILP: LDA     (TMP),Y
        AND     #$7F
        STA     (TMP),Y
        DEY
        BNE     CLHILP
:
end
asm sethibit(strptr)
        LDY     #$02        ; strptr
        LDA     (FP),Y
        STA     TMPL
        INY
        LDA     (FP),Y
        STA     TMPH
        LDY     #$00
        LDA     (TMP),Y
        BEQ     :+
        TAY
STHILP: LDA     (TMP),Y
        ORA     #$80
        STA     (TMP),Y
        DEY
        BNE     STHILP
:
end
asm cpyln(srcstr, dststr)
        LDY     #$02        ; srcstr
        LDA     (FP),Y
        STA     TMPL
        INY
        LDA     (FP),Y
        STA     TMPH
        INY                 ; dststr
        LDA     (FP),Y
        STA     $06
        INY
        LDA     (FP),Y
        STA     $07
        LDY     #$00
        LDA     (TMP),Y
        TAY
        LDA     #$00
        INY
        STA     ($06),Y
        DEY
        BEQ     :++
CPLNLP: LDA     (TMP),Y
        CMP     #$20
        BCS     :+
        ADC     #$60
:       AND     #$7F
        STA     ($06),Y
        DEY
        BNE     CPLNLP
        LDA     (TMP),Y
:       STA     ($06),Y
end
;
; File routines
;
def readtxt(filename)
    byte txtbuf[81], refnum, i, j

    refnum = open(filename, iobuffer)
    if refnum == 0
        return 0
    fin
    newline(refnum, $7F, $0D)
    repeat
        txtbuf = read(refnum, @txtbuf + 1, maxlnlen)
        if txtbuf
            sethibit(@txtbuf)
            if flags & uppercase
                strupper(@txtbuf)
            fin
            strlinbuf:[numlines] = newstr(@txtbuf)
            numlines = numlines + 1
        fin
        if !(numlines & $0F)
            cout('.')
        fin
    until txtbuf == 0 or numlines == maxlines
    close(refnum)
end
def writetxt(filename)
    byte txtbuf[81], refnum
    byte j, chr
    word i, strptr

    destroy(filename)
    create(filename, $C3, $04, $00) ; full access, TXT file
    refnum = open(filename, iobuffer)
    if refnum == 0
        return 0
    fin
    for i = 0 to numlines - 1
        cpyln(strlinbuf:[i], @txtbuf)
        txtbuf = txtbuf + 1
        txtbuf[txtbuf] = $0D
        write(refnum, @txtbuf + 1, txtbuf)
        if !(i & $0F)
            cout('.')
        fin
    next
    close(refnum)
end
;
; Screen routines
;
def drawrow(row, ofst, strptr)
    byte numchars
    word scrnptr

    scrnptr = txtscrn[row]
    if ^strptr <= ofst
        numchars = 0
    else
        numchars = ^strptr - ofst
    fin
    if numchars >= 40
        numchars = 40
    else
        memset($A0A0, scrnptr + numchars, 40 - numchars)
    fin
    memcpy(strptr + ofst + 1, scrnptr, numchars)
end
deft drawscrn(toprow, ofst)
    byte row, numchars
    word strptr, scrnptr

    for row = 0 to 23
        strptr  = strlinbuf:[toprow + row]
        scrnptr = txtscrn[row]
        if ^strptr <= ofst
            numchars = 0
        else
            numchars = ^strptr - ofst
        fin
        if numchars >= 40
            numchars = 40
        else
            memset($A0A0, scrnptr + numchars, 40 - numchars)
        fin
        memcpy(strptr + ofst + 1, scrnptr, numchars)
    next
end
def cursoff
    if flags & showcurs
        ^cursptr = underchr
        flags = flags & #showcurs
    fin
end
def curson
    if !(flags & showcurs)
        cursptr  = txtscrn[cursy] + cursx
        underchr = ^cursptr
        ^cursptr = curschr
        flags = flags ? showcurs
    fin
end
def cursflash
    if flags & showcurs
        if flash == 0
	    ^cursptr = curschr
        elsif flash == 128
	    ^cursptr = underchr
        fin
        flash = flash + 1
    fin
end
def redraw
    cursoff
    drawscrn(scrntop, scrnleft)
    curson
end
def curshome
    cursoff
    cursrow  = 0
    curscol  = 0
    cursx    = 0
    cursy    = 0
    scrnleft = 0
    scrntop  = 0
    drawscrn(scrntop, scrnleft)
    curson
end
def cursend
    cursoff
    if numlines > 23
        cursrow  = numlines - 1
        cursy    = 23
        scrntop    = cursrow - 23
    else
        cursrow  = numlines - 1
        cursy    = numlines - 1
        scrntop    = 0
    fin
    curscol  = 0
    cursx    = 0
    scrnleft = 0
    drawscrn(scrntop, scrnleft)
    curson
end
def cursup
    if cursrow > 0
        cursoff
        cursrow = cursrow - 1
        if cursy > 0
            cursy = cursy - 1
        else
            scrntop = cursrow
            drawscrn(scrntop, scrnleft)
        fin
        curson
    fin
end
def pgup
    byte i

    for i = pgjmp downto 0
        cursup
    next
end
def cursdown
    if cursrow < numlines - 1
        cursoff
        cursrow = cursrow + 1
        if cursy < 23
            cursy = cursy + 1
        else
            scrntop = cursrow - 23
            drawscrn(scrntop, scrnleft)
        fin
        curson
    fin
end
def pgdown
    byte i

    for i = pgjmp downto 0
        cursdown
    next
end
def cursleft
    if curscol > 0
        cursoff
        curscol = curscol - 1
        if cursx > 0
            cursx = cursx - 1
        else
            scrnleft = curscol
            drawscrn(scrntop, scrnleft)
        fin
        curson
    fin
end
def pgleft
    byte i

    for i = 7 downto 0
        cursleft
    next
end
def cursright
    if curscol < 80
        cursoff
        curscol = curscol + 1
        if cursx < 39
            cursx = cursx + 1
        else
            scrnleft = curscol - 39
            drawscrn(scrntop, scrnleft)
        fin
        curson
    fin
end
def pgright
    byte i

    for i = 7 downto 0
        cursright
    next
end
;
; Keyboard routines
;
def keyin2e
    repeat
        cursflash
    until ^keyboard >= 128
    return ^keystrobe
end
def keyin2
    byte key, flash

    repeat
        cursflash
        key = ^keyboard
        if key == keyctrll
            ^keystrobe
            flags = flags ^ shiftlock
            key   = 0
        fin
    until key >= 128
    ^keystrobe
    if key == keyctrln
        key = $DB ; [
    elsif key == keyctrlp
        key = $DF ; _
    elsif key == keyctrlb
        key = $DC ; \
    elsif key == keyarrowleft
        if ^pushbttn3 < 128
            key = $FF
        fin
    elsif key >= $C0 and flags < shiftlock
        if ^pushbttn3 < 128
            if key == $C0
                key = $D0 ; P
            elsif key == $DD
                key = $CD ; M
            elsif key == $DE
                key = $CE ; N
            fin
        else
           key = key ? $E0
        fin
    fin
    return key
end
;
; Printer routines
;
def printtxt(slot)
    byte txtbuf[80]
    word i, scrncsw

    scrncsw = *(csw)
    *(csw)  = $C000 ? (slot << 8)
    for i = 0 to numlines - 1
        cpyln(strlinbuf:[i], @txtbuf)
        prstr(@txtbuf)
        crout
    next
    *(csw) = scrncsw
end
def openline(row)
    if numlines < maxlines
        memcpy(@strlinbuf:[row], @strlinbuf:[row + 1], (numlines - row) * 2)
        strlinbuf:[row] = @nullstr
        numlines = numlines + 1
        flags = flags ? changed
        return 1
    fin
    bell
    return 0
end
def cutline
    freestr(cutbuf)
    cutbuf = strlinbuf:[cursrow]
    memcpy(@strlinbuf:[cursrow + 1], @strlinbuf:[cursrow], (numlines - cursrow) * 2)
    if numlines > 1
        numlines = numlines - 1
    fin
    flags = flags ? changed
    if cursrow == numlines
        cursup
    fin
    redraw
end
def pasteline
    if cutbuf and numlines < maxlines
        memcpy(@strlinbuf:[cursrow], @strlinbuf:[cursrow + 1], (numlines - cursrow) * 2)
        strlinbuf:[cursrow] = newstr(cutbuf)
        numlines = numlines + 1
        flags = flags ? changed
        redraw
    else
        bell
    fin
end
def joinline
    byte joinstr[80], joinlen

    if cursrow < numlines - 1
        strcpy(strlinbuf:[cursrow], @joinstr)
        joinlen = joinstr + ^(strlinbuf:[cursrow + 1])
        if joinlen < 80
            memcpy(strlinbuf:[cursrow + 1] + 1, @joinstr + joinstr + 1, ^(strlinbuf:[cursrow + 1]))
            joinstr = joinlen
            freestr(strlinbuf:[cursrow])
            strlinbuf:[cursrow] = newstr(@joinstr)
            freestr(strlinbuf:[cursrow + 1])
            numlines = numlines - 1
            memcpy(@strlinbuf:[cursrow + 2], @strlinbuf:[cursrow + 1], (numlines - cursrow) * 2)
            flags = flags ? changed
            redraw
        else
            bell
        fin
    fin
end
def splitline
    byte splitstr[80], splitlen

    if openline(cursrow + 1)
        if curscol
            splitlen = ^(strlinbuf:[cursrow])
            if curscol < splitlen - 1
                memcpy(strlinbuf:[cursrow] + curscol + 1, @splitstr + 1, splitlen - curscol)
                splitstr = splitlen - curscol
                strlinbuf:[cursrow + 1] = newstr(@splitstr)
                memcpy(strlinbuf:[cursrow] + 1, @splitstr + 1, curscol)
                splitstr = curscol
                freestr(strlinbuf:[cursrow])
                strlinbuf:[cursrow] = newstr(@splitstr)
            fin
        else
            strlinbuf:[cursrow + 1] = strlinbuf:[cursrow]
            strlinbuf:[cursrow]     = @nullstr
        fin
        curscol  = 0
        cursx    = 0
        scrnleft = 0
        redraw
        cursdown
    fin
end
def editkey(key)
    if key >= keyspace
        return 1
    elsif key == keydelete
        return 1
    elsif key == keyctrld
        return 1
    elsif key == keyctrlr
        return 1
    fin
end
def editline(key)
    byte editstr[80]
    word undoline

    if (editkey(key))
        flags = flags ? changed
        memset($A0A0, @editstr, 80)
        strcpy(strlinbuf:[cursrow], @editstr)
        undoline = strlinbuf:[cursrow]
        strlinbuf:[cursrow] = @editstr
        repeat
            if key >= keyspace
                if key == keydelete
                    if curscol > 0
                        if curscol <= editstr
                            memcpy(@editstr[curscol + 1], @editstr[curscol], editstr - curscol)
                            editstr = editstr - 1
                        fin
                        curscol = curscol - 1
                        cursoff
                        if cursx > 0
                            cursx = cursx - 1
                            drawrow(cursy, scrnleft, @editstr)
                        else
                            scrnleft = scrnleft - 1
                            drawscrn(scrntop, scrnleft)
                        fin
                        curson
                    fin
                elsif curscol < maxlnlen
                    curscol = curscol + 1
                    cursx   = cursx   + 1
                    if flags & insmode
                        if editstr < maxlnlen or editstr.maxlnlen == $A0
                            editstr = editstr + 1
                            if curscol >= editstr
                                editstr = curscol
                            else
                                memcpy(@editstr[curscol], @editstr[curscol + 1], editstr - curscol)
                            fin
                        else
                            curscol = curscol - 1
                            cursx   = cursx   - 1
                            key     = editstr[curscol]
                            bell
                        fin
                    else
                        if curscol > editstr
                            editstr = curscol
                        fin
                    fin
                    editstr[curscol] = caseconv(key)
                    cursoff
                    if cursx <= 39
                        drawrow(cursy, scrnleft, @editstr)
                    else
                        scrnleft = scrnleft + 1
                        cursx    = 39
                        drawscrn(scrntop, scrnleft)
                    fin
                    curson
                else
                    bell
                fin
            elsif key == keyctrld
                if curscol < editstr
                    memcpy(@editstr[curscol + 2], @editstr[curscol + 1], editstr - curscol)
                    editstr = editstr - 1
                    cursoff
                    drawrow(cursy, scrnleft, @editstr)
                    curson
                fin
            elsif key == keyctrlr
                strcpy(undoline, @editstr)
                cursoff
                drawrow(cursy, scrnleft, @editstr)
                curson
            fin
            key = keyin()
        until !editkey(key)
        if editstr
            strlinbuf:[cursrow] = newstr(@editstr)
        else
            strlinbuf:[cursrow] = @nullstr
        fin
        freestr(undoline)
    fin
    return key
end
def editmode
    repeat
        when editline(keyin())
            is keyarrowup
                cursup
            is keyarrowdown
                cursdown
            is keyarrowleft
                cursleft
            is keyarrowright
                cursright
            is keyctrlw
                pgup
            is keyctrlz
                pgdown
            is keyctrla
                pgleft
            is keyctrls
                pgright
            is keyctrlq
                curshome
            is keyctrle
                cursend
            is keyctrlx
                cutline
            is keyctrlv
                pasteline
            is keyctrlo
                openline(cursrow)
                redraw
            is keyenter
                if flags & insmode
                    splitline
                else
                    openline(cursrow + 1)
                    cursdown
                    redraw
                fin
            is keyctrlt
                joinline
            is keyctrli
                if flags & insmode
                    flags = flags & #insmode
                    curschr = ' '
                else
                    flags = flags ? insmode
                    curschr = '+'
                fin
            is keyctrlc
                if flags & uppercase
                    txtlower
                else
                    txtupper
                fin
                redraw
            is keyescape
                cursoff
                cmdmode
                redraw
            otherwise
                bell
        wend
    until 0
end
;
; Command mode
;
def prfiles(optpath)
    byte path[64]
    byte refnum
    byte firstblk
    byte entrylen, entriesblk
    byte i, type, len
    word entry, filecnt

    if ^optpath
        strcpy(optpath, @path)
    else
        getpfx(@path)
        prstr(@path)
        crout
    fin
    refnum = open(@path, iobuffer);
    if perr
        return perr
    fin
    firstblk = 1
    repeat
        if read(refnum, databuff, 512) == 512
            entry = databuff + 4
            if firstblk
                entrylen   = databuff.$23
                entriesblk = databuff.$24
                filecnt    = databuff:$25
                entry      = entry + entrylen
            fin
            for i = firstblk to entriesblk
                type = ^entry
                if type <> 0
                    len = type & $0F
                    ^entry = len
                    prstr(entry)
                    if type & $F0 == $D0 ; Is it a directory?
                        cout('/')
                        len = len + 1
                    fin
                    for len = 20 - len downto 1
                        cout(' ')
                    next
                    filecnt = filecnt - 1
                fin
                entry = entry + entrylen
            next
            firstblk = 0
        else
            filecnt = 0
        fin
    until filecnt == 0
    close(refnum)
    crout
    return 0
end
def striplead(strptr, chr)
    while ^strptr and ^(strptr + 1) == chr
        memcpy(strptr + 2, strptr + 1, ^strptr)
        ^strptr = ^strptr - 1
    loop
end
def parsecmd(strptr)
    byte cmd

    cmd = 0
    striplead(strptr, $A0)
    if ^strptr
        cmd = ^(strptr + 1)
        striplead(strptr, cmd)
    fin
    if ^strptr
        striplead(strptr, $A0)
    fin
    return cmd & $7F
end
def upcase(chr)
    if chr >= 'a' and chr <= 'z'
        chr = chr - 'a' + 'A'
    fin
    return chr
end
def chkchng
    if flags & changed
        prstr(@losechng)
        if upcase(keyin() & $7F) == 'N'
            crout
            return 0
        fin
        crout
    fin
    return 1
end
def quit
    if chkchng
        exit
    fin
end
def cmdmode
    byte slot
    word cmdptr

    romcall(0, 0, 0, 0, $FC58)
    crout
    while 1
        prstr(@txtfile)
        cmdptr = rdstr($BA)
        when upcase(parsecmd(cmdptr))
            is 'A'
                readtxt(cmdptr)
                flags = flags ? changed
            is 'R'
                if chkchng
                    inittxtbuf
                    strcpy(cmdptr, @txtfile)
                    readtxt(@txtfile)
                    entrypoint = 0
                    flags = flags & #changed
                fin
            is 'W'
                if ^cmdptr
                    strcpy(cmdptr, @txtfile)
                fin
                writetxt(@txtfile)
                if flags & changed
                    entrypoint = 0
                fin
                flags = flags & #changed
            is 'Q'
                quit
            is 'C'
                prfiles(cmdptr)
            is 'P'
                setpfx(cmdptr)
            is 'H'
                if ^cmdptr
                    slot = cmdptr.1 & $7F - '0'
                else
                    slot = 1
                fin
                printtxt(slot)
            is 'E'
                return
            is 0
                return
            is 'N'
                if chkchng
                    inittxtbuf
                    numlines = 1
                    strcpy(@untitled, @txtfile)
                fin
            is 'X'
                if flags & changed or !entrypoint
                    parse_module
                    if parserr
                        bell
                        cursrow  = parserrln
                        scrntop  = cursrow & $FFF8
                        cursy    = cursrow - scrntop
                        curscol  = parserrpos
                        scrnleft = curscol & $FFE0
                        cursx    = curscol - scrnleft
                    else
                        crout
                        (entrypoint)()
                    fin
                else
                    (entrypoint)()
                fin
                crout
            is 'V'
				prstr(@version)
        wend
        if perr
            prstr(@errorstr)
            romcall(perr, 0, 0, 0, $FDDA)
        else
            prstr(@okstr)
        fin
        crout
    loop
end

;=====================================
;
;           PLASMA Compiler
;
;=====================================

;
; Error handler
;
def parse_err(err)
    if !parserr
        parserr    = TRUE
        parserrln  = lineno - 1
        parserrpos = tknptr - inbuff
        print(lineno)
        cout(':')
        prstr(err)
        crout
    fin
	return ERR_TKN
end
;
; Emit bytecode
;
def ctag_new
    if codetag >= ctag_max
        return parse_err(@ctag_full)
    fin
	codetag = codetag + 1
    ctag_value:[codetag] = 0
    ctag_flags.[codetag] = 0
	return codetag ? is_ctag
end
def ctag_resolve(tag, addr)
    word updtptr, nextptr

    tag = tag & mask_ctag
    if ctag_flags.[tag] & resolved
        return parse_err(@dup_id)
    fin
    updtptr = ctag_value:[tag]
    while updtptr
        ;
        ; Update list of addresses needing resolution
        ;
        nextptr  = *updtptr
        *updtptr = addr
        updtptr  = nextptr
    loop
    ctag_value:[tag] = addr
    ctag_flags.[tag] = ctag_flags.[tag] ? resolved
end
defn emit_byte(bval)
    ^codeptr = bval
    codeptr  = codeptr + 1
end
defn emit_word(wval)
    *codeptr = wval
    codeptr  = codeptr + 2
end
def emit_fill(size)
	memset(0, codeptr, size)
	codeptr = codeptr + size
end
def emit_codetag(tag)
    return ctag_resolve(tag, codeptr)
end
deft emit_op(op)
    lastop = op
    return emit_byte(op)
end
def emit_tag(tag)
    word updtptr

    if tag & is_ctag
        tag = tag & mask_ctag
        updtptr = ctag_value:[tag]
        if !(ctag_flags.[tag] & resolved)
            ;
            ; Add to list of tags needing resolution
            ;
            ctag_value:[tag] = codeptr
        fin
        emit_word(updtptr)
    else
        emit_word(tag + codebuff)
    fin
end
def emit_iddata(value, size, namestr)
	return emit_fill(size)
end
def emit_data(vartype, consttype, constval, constsize)
	byte i
	word size, chrptr

	if consttype == 0
		size = constsize
		emit_fill(constsize)
	elsif consttype == STR_TYPE
		size = constsize
		chrptr = constval
		constsize = constsize - 1
		emit_byte(constsize)
		while constsize > 0
		  emit_byte(^chrptr)
			chrptr    = chrptr + 1
			constsize = constsize - 1
		loop
	else
		if vartype == WORD_TYPE
			size = 2
			emit_word(constval)
		else
			size = 1
			emit_byte(constval)
		fin
	fin
	return size
end
def emit_const(cval)
	if cval == 0
		emit_op($00)
	elsif cval > 0 and cval < 256
		emit_op($2A)
		emit_byte(cval)
	else
		emit_op($2C)
		emit_word(cval)
	fin
end
def emit_lb
	return emit_op($60)
end
def emit_lw
	return emit_op($62)
end
def emit_llb(index)
	emit_op($64)
	return emit_byte(index)
end
def emit_llw(index)
	emit_op($66)
	return emit_byte(index)
end
def emit_lab(tag)
	emit_op($68)
	return emit_tag(tag)
end
def emit_law(tag)
	emit_op($6A)
	return emit_tag(tag)
end
def emit_sb
	return emit_op($70)
end
def emit_sw
	return emit_op($72)
end
def emit_slb(index)
	emit_op($74)
	return emit_byte(index)
end
def emit_slw(index)
	emit_op($76)
	return emit_byte(index)
end
def emit_dlb(index)
	emit_op($6C)
	return emit_byte(index)
end
def emit_dlw(index)
	emit_op($6E)
	return emit_byte(index)
end
def emit_sab(tag)
	emit_op($78)
	return emit_tag(tag)
end
def emit_saw(tag)
	emit_op($7A)
	return emit_tag(tag)
end
def emit_dab(tag)
	emit_op($7C)
	return emit_tag(tag)
end
def emit_daw(tag)
	emit_op($7E)
	return emit_tag(tag)
end
def emit_call(tag, cparams)
	emit_op($54)
	return emit_tag(tag)
end
def emit_ical(cparams)
	emit_op($56)
	return emit_byte(cparams)
end
def emit_push
        emit_op($34)
end
def emit_pull
        ;
        ; Skip if last op was push
        ;
        if lastop == $34
                codeptr = codeptr - 1
		lastop = $FF
        else
                emit_op($36)
        fin
end
def emit_localaddr(index)
	emit_op($28)
	return emit_byte(index)
end
def emit_globaladdr(tag)
	emit_op($26)
	return emit_tag(tag)
end
def emit_indexbyte
	return emit_op($2E)
end
def emit_indexword
	return emit_op($1E)
end
def emit_unaryop(op)
	when op
		is NEG_TKN
	        emit_op($10)
		is COMP_TKN
	        emit_op($12)
		is LOGIC_NOT_TKN
	        emit_op($20)
		is INC_TKN
	        emit_op($0C)
		is DEC_TKN
	        emit_op($0E)
		is BPTR_TKN
	        emit_op($60)
		is WPTR_TKN
	        emit_op($62)
		otherwise
			return FALSE
	wend
	return TRUE
end
def emit_binaryop(op)
	when op
		is MUL_TKN
		    ;
		    ; Replace MUL 2 with SHL 1
		    ;
		    if lastop == $2A and ^(codeptr - 1) == 2 ; CB 2
    		    codeptr = codeptr - 1
    		    emit_byte(1) ; CB 1
    		    emit_op($1A) ; SHL
    		else
    	        emit_op($06)
    	    fin
		is DIV_TKN
		    ;
		    ; Replace DIV 2 with SHR 1
		    ;
		    if lastop == $2A and ^(codeptr - 1) == 2 ; CB 2
    		    codeptr = codeptr - 1
    		    emit_byte(1) ; CB 1
    		    emit_op($1C) ; SHR
    		else
    	        emit_op($08)
    	    fin
		is MOD_TKN
	        emit_op($0A)
		is ADD_TKN
		    ;
		    ; Replace ADD 1 with INCR
		    ;
		    if lastop == $2A and ^(codeptr - 1) == 1 ; CB 1
    		    codeptr = codeptr - 2
    		    emit_op($0C) ; INC_OP
    		else
    	        emit_op($02)
    	    fin
		is SUB_TKN
		    ;
		    ; Replace SUB 1 with DECR
		    ;
		    if lastop == $2A and ^(codeptr - 1)  == 1 ; CB 1
    		    codeptr = codeptr - 2
    		    emit_op($0E) ; DEC_OP
    		else
                emit_op($04)
    	    fin
		is SHL_TKN
	        emit_op($1A)
		is SHR_TKN
	        emit_op($1C)
		is AND_TKN
	        emit_op($14)
		is OR_TKN
	        emit_op($16)
		is EOR_TKN
	        emit_op($18)
		is EQ_TKN
	        emit_op($40)
		is NE_TKN
	        emit_op($42)
		is GE_TKN
	        emit_op($48)
		is LT_TKN
	        emit_op($46)
		is GT_TKN
	        emit_op($44)
		is LE_TKN
	        emit_op($4A)
		is LOGIC_OR_TKN
	        emit_op($22)
		is LOGIC_AND_TKN
	        emit_op($24)
		otherwise
			return FALSE
	wend
	return TRUE
end
def emit_brtru(tag)
	emit_op($4E)
	return emit_tag(tag)
end
def emit_brfls(tag)
	emit_op($4C)
	return emit_tag(tag)
end
def emit_brgt(tag)
	emit_op($3A)
	return emit_tag(tag)
end
def emit_brlt(tag)
	emit_op($38)
	return emit_tag(tag)
end
def emit_brne(tag)
	emit_op($3E)
	return emit_tag(tag)
end
def emit_jump(tag)
	emit_op($50)
	return emit_tag(tag)
end
def emit_drop
	return emit_op($30)
end
def emit_leave(framesize)
    if framesize > 2
  	    emit_op($5A)
    else
  	    emit_op($5C)
    fin
end
def emit_enter(framesize, cparams)
    emit_byte(emit_enter.[0])
    emit_byte(emit_enter.[1])
    emit_byte(emit_enter.[2])
    if framesize > 2
        emit_op($58)
        emit_byte(framesize)
        emit_byte(cparams)
    fin
end
def emit_start
    ;
    ; Save address
    ;
    entrypoint = codeptr
    emit_byte(emit_start.[0])
    emit_byte(emit_start.[1])
    return emit_op(emit_start.[2])
end
def emit_exit
    emit_op($00)
    return emit_op($5C)
end
;
; Lexical anaylzer
;
;defn isalpha(c)
;	if c >= 'A' and c <= 'Z'
;		return TRUE
;	elsif c >= 'a' and c <= 'z'
;		return TRUE
;	elsif c == '_'
;		return TRUE
;	fin
;	return FALSE
;end
asm isalpha
        LDY     #$00
        LDA     ESTKL,X
        CMP     #'A'
        BCC     ISALRET
        CMP     #'Z'+1
        BCS     :+
        DEY
        BNE     ISALRET
:       CMP     #'a'
        BCC     ISALRET
        CMP     #'z'+1
        BCS     :+
        DEY
        BNE     ISALRET
:       CMP     #'_'
        BNE     ISALRET
        DEY
ISALRET:
        STY     ESTKL,X
        STY     ESTKH,X
        RTS
end
;defn isnum(c)
;	if c >= '0' and c <= '9'
;		return TRUE
;	fin
;	return FALSE
;end
asm isnum
        LDY     #$00
        LDA     ESTKL,X
        CMP     #'0'
        BCC     :+
        CMP     #'9'+1
        BCS     :+
        DEY
:       STY     ESTKL,X
        STY     ESTKH,X
        RTS
end
;defn isalphanum(c)
;	if c >= 'A' and c <= 'Z'
;		return TRUE
;	elsif c >= '0' and c <= '9'
;		return TRUE
;	elsif c >= 'a' and c <= 'z'
;		return TRUE
;	elsif c == '_'
;		return TRUE
;	fin
;	return FALSE
;end
asm isalphanum
        LDY     #$00
        LDA     ESTKL,X
        CMP     #'0'
        BCC     ISANRET
        CMP     #'9'+1
        BCS     :+
        DEY
        BNE     ISANRET
:       CMP     #'A'
        BCC     ISANRET
        CMP     #'Z'+1
        BCS     :+
        DEY
        BNE     ISANRET
:       CMP     #'a'
        BCC     ISANRET
        CMP     #'z'+1
        BCS     :+
        DEY
        BNE     ISANRET
:       CMP     #'_'
        BNE     ISANRET
        DEY
ISANRET:
        STY     ESTKL,X
        STY     ESTKH,X
        RTS
end
deft keymatch(chrptr, len)
	byte i, keypos

	keypos = 0
	while keywrds[keypos] < len
		keypos = keypos + keywrds[keypos] + 2
	loop
	while keywrds[keypos] == len
		for i = 1 to len
			if toupper((chrptr).[i - 1]) <> keywrds[keypos + i]
				break
			fin
		next
		if i > len
			return keywrds[keypos + keywrds[keypos] + 1]
		fin
		keypos = keypos + keywrds[keypos] + 2
	loop
	return ID_TKN
end
def skipspace
	;
	; Skip whitespace
	;
	while ^scanptr and ^scanptr <= ' '
		scanptr = scanptr + 1
	loop
	tknptr = scanptr
	return !^scanptr or ^scanptr == ';'
end
deft scan
	;
	; Scan for token based on first character
	;
	if skipspace
		if token <> EOF_TKN
		    token = EOL_TKN
		fin
	elsif isalpha(^scanptr)
		;
		; ID,	 either variable name or reserved word
		;
		repeat
			scanptr = scanptr + 1
		until !isalphanum(^scanptr)
		tknlen = scanptr - tknptr;
		token = keymatch(tknptr, tknlen)
	elsif isnum(^scanptr)
		;
		; Number constant
		;
		token		= INT_TKN
		constval = 0
		repeat
			constval = constval * 10 + ^scanptr - '0'
			scanptr	 = scanptr + 1
		until !isnum(^scanptr)
	elsif ^scanptr == '$'
		;
		; Hexadecimal constant
		;
		token	 = INT_TKN;
		constval = 0
		repeat
			scanptr = scanptr + 1
			if ^scanptr >= '0' and ^scanptr <= '9'
				constval = (constval << 4) + ^scanptr - '0'
			elsif ^scanptr >= 'A' and ^scanptr <= 'F'
				constval = (constval << 4) + ^scanptr - '7'; 'A'-10
			elsif ^scanptr >= 'a' and ^scanptr <= 'f'
				constval = (constval << 4) + ^scanptr - 'W'; 'a'-10
			else
				break;
			fin
		until !^scanptr
	elsif ^scanptr == $27 ; '
		;
		; Character constant
		;
		token = CHR_TKN
		if ^(scanptr + 1) <> $5C ; \
			constval = ^(scanptr + 1)
			if ^(scanptr + 2) <> $27 ; '
				return parse_err(@bad_cnst)
			fin
			scanptr = scanptr + 3
		else
			when ^(scanptr + 2)
				is 'n'
					constval = $0D
				is 'r'
					constval = $0A
				is 't'
					constval = $09
				otherwise
					constval = ^(scanptr + 2)
			wend
			if ^(scanptr + 3) <> $27 ; '
				return parse_err(@bad_cnst)
			fin
			scanptr = scanptr + 4
		fin
	elsif ^scanptr == '"'
		;
		; String constant
		;
		token    = STR_TKN
		scanptr	 = scanptr + 1
		constval = scanptr
		while ^scanptr and ^scanptr <> '"'
			scanptr = scanptr + 1
		loop
		if !^scanptr
			return parse_err(@bad_cnst)
		fin
		scanptr = scanptr + 1
	else
		;
		; Potential two and three character tokens
		;
		when ^scanptr
			is '>'
				if ^(scanptr + 1) == '>'
					token	= SHR_TKN
					scanptr = scanptr + 2
				elsif ^(scanptr + 1) == '='
					token	= GE_TKN
					scanptr = scanptr + 2
				else
					token	= GT_TKN
					scanptr = scanptr + 1
				fin
			is '<'
				if ^(scanptr + 1) == '<'
					token	= SHL_TKN
					scanptr = scanptr + 2
				elsif ^(scanptr + 1) == '='
					token	= LE_TKN
					scanptr = scanptr + 2
				elsif ^(scanptr + 1) == '>'
					token	= NE_TKN
					scanptr = scanptr + 2
				else
					token   = LT_TKN
					scanptr = scanptr + 1
				fin
			is '='
				if ^(scanptr + 1) == '='
					token	= EQ_TKN
					scanptr = scanptr + 2;
				else
					token	= SET_TKN;
					scanptr = scanptr + 1
				fin
			otherwise
				;
				; Simple single character tokens
				;
				token	= ^scanptr ? $80
				scanptr = scanptr + 1
		wend
	fin
	tknlen = scanptr - tknptr
	return token
end
def rewind(ptr)
	scanptr = ptr
end
;
; Get next line of input
;
def nextln
;	if ^keyboard == $A0
;        ^keystrobe
;        while ^keyboard < 128
;        loop
;        ^keystrobe
;    elsif ^keyboard == $82
;        lineno = numlines
;        ^keystrobe
;	fin
    scanptr = inbuff
    if lineno < numlines
        cpyln(strlinbuf:[lineno], instr)
        lineno = lineno + 1
        if !(lineno & $0F)
            cout('.')
        fin
        ; cout('>')
        ; prstr(instr)
        ; crout
        scan
    else
        ^instr  = 0
        ^inbuff = $00
        token   = DONE_TKN
    fin
	return ^instr
end
;
; Alebraic op to stack op
;
def push_op(op, prec)
	opsp = opsp + 1
	if opsp == 16
		return parse_err(@estk_overflw)
	fin
	opstack[opsp]   = op
	precstack[opsp] = prec
end
def pop_op
	if opsp < 0
		return parse_err(@estk_underflw)
	fin
	opsp = opsp - 1
	return opstack[opsp + 1]
end
def tos_op
	if opsp < 0
		return 0
	fin
	return opstack[opsp]
end
def tos_op_prec(tos)
	if opsp <= tos
		return 100
	fin
	return precstack[opsp]
end
;
; Symbol table
;
deft idmatch(nameptr, len, idptr, idcnt)
	byte i

	while idcnt
		if len == (idptr).idname
			for i = 1 to len
				if (nameptr).[i - 1] <> (idptr).idname.[i]
					break
				fin
			next
			if i > len
				return idptr
			fin
		fin
		idptr = idptr + (idptr).idname + idrecsz
		idcnt = idcnt - 1
	loop
	return 0
end
def dumpsym(idptr, idcnt)
	while idcnt
		prword((idptr):idval)
		cout(' ')
		prbyte((idptr).idtype)
		cout(' ')
		prstr(@(idptr).idname)
		cout('=')
		if (idptr).idtype & ADDR_TYPE
            if (idptr):idval & is_ctag
                prword(ctag_value:[(idptr):idval & mask_ctag])
            else
                prword((idptr):idval + codebuff)
            fin
        else
            prword((idptr):idval)
        fin
		crout
		idptr = idptr + (idptr).idname + idrecsz
		idcnt = idcnt - 1
	loop
end
def id_lookup(nameptr, len)
    word idptr

    idptr = idmatch(nameptr, len, idlocal_tbl, locals)
	if idptr
		return idptr
	fin
	idptr = idmatch(nameptr, len, idglobal_tbl, globals)
	if idptr
		return idptr
	fin
	return parse_err(@undecl_id)
end
def idglobal_lookup(nameptr, len)
	return idmatch(nameptr, len, idglobal_tbl, globals)
end
def idlocal_add(namestr, len, type, size)
	if idmatch(namestr, len, @idlocal_tbl, locals)
		return parse_err(@dup_id)
	fin
	(lastlocal):idval  = framesize
	(lastlocal).idtype = type ? LOCAL_TYPE
	nametostr(namestr, len, lastlocal + idname)
	locals	  = locals + 1
	lastlocal = lastlocal + idrecsz + len
	if lastlocal > idlocal_tbl + idlocal_tblsz
		prstr(@local_sym_overflw)
		exit
	fin
	framesize = framesize + size
	if framesize > 255
		prstr(@local_overflw)
		return FALSE
	fin
	return TRUE
end
def iddata_add(namestr, len, type, size)
	if idmatch(namestr, len, idglobal_tbl, globals)
		return parse_err(@dup_id)
	fin
	(lastglobal):idval	= datasize
	(lastglobal).idtype = type
	nametostr(namestr, len, lastglobal + idname)
	emit_iddata(datasize, size, lastglobal + idname)
	globals	   = globals + 1
	lastglobal = lastglobal + idrecsz + len
	if lastglobal > idglobal_tbl + idglobal_tblsz
		prstr(@global_sym_overflw)
		exit
	fin
	datasize = datasize + size
	return TRUE
end
def iddata_size(type, varsize, initsize)
	if varsize > initsize
		datasize = datasize + emit_data(0, 0, 0, varsize - initsize)
	else
		datasize = datasize + initsize
	fin
;	if datasize <> codeptr - codebuff
;	    prstr(@emiterr)
;	    keyin()
;	fin
end
def idglobal_add(namestr, len, type, value)
	if idmatch(namestr, len, idglobal_tbl, globals)
		return parse_err(@dup_id)
	fin
	(lastglobal):idval	= value
	(lastglobal).idtype = type
	nametostr(namestr, len, lastglobal + idname)
	globals	   = globals + 1
	lastglobal = lastglobal + idrecsz + len
	if lastglobal > idglobal_tbl + idglobal_tblsz
		prstr(@global_sym_overflw)
		exit
	fin
	return TRUE
end
def idfunc_add(namestr, len, tag)
	return idglobal_add(namestr, len, FUNC_TYPE, tag)
end
def idconst_add(namestr, len, value)
	return idglobal_add(namestr, len, CONST_TYPE, value)
end
def idglobal_init
    word ctag

    lineno       = 0
    parserr      = 0
    codeptr      = codebuff
    lastop       = $FF
    entrypoint   = 0
	datasize	 = 0
	globals		 = 0
	lastglobal   = idglobal_tbl
	codetag      = -1
	ctag = ctag_new
	idfunc_add(@runtime0 + 1, runtime0, ctag)
	idfunc_add(@RUNTIME0 + 1, RUNTIME0, ctag)
	ctag_resolve(ctag, @romcall)
	ctag = ctag_new
	idfunc_add(@runtime1 + 1, runtime1, ctag)
	idfunc_add(@RUNTIME1 + 1, RUNTIME1, ctag)
	ctag_resolve(ctag, @syscall)
	ctag = ctag_new
	idfunc_add(@runtime2 + 1, runtime2, ctag)
	idfunc_add(@RUNTIME2 + 1, RUNTIME2, ctag)
	ctag_resolve(ctag, @memset)
	ctag = ctag_new
	idfunc_add(@runtime3 + 1, runtime3, ctag)
	idfunc_add(@RUNTIME3 + 1, RUNTIME3, ctag)
	ctag_resolve(ctag, @memcpy)
	ctag = ctag_new
	idfunc_add(@runtime4 + 1, runtime4, ctag)
	idfunc_add(@RUNTIME4 + 1, RUNTIME4, ctag)
	ctag_resolve(ctag, @cout)
	ctag = ctag_new
	idfunc_add(@runtime5 + 1, runtime5, ctag)
	idfunc_add(@RUNTIME5 + 1, RUNTIME5, ctag)
	ctag_resolve(ctag, @cin)
	ctag = ctag_new
	idfunc_add(@runtime6 + 1, runtime6, ctag)
	idfunc_add(@RUNTIME6 + 1, RUNTIME6, ctag)
	ctag_resolve(ctag, @prstr)
	ctag = ctag_new
	idfunc_add(@runtime7 + 1, runtime7, ctag)
	idfunc_add(@RUNTIME7 + 1, RUNTIME7, ctag)
	ctag_resolve(ctag, @rdstr)
end
def idlocal_init
	locals	  = 0
	framesize = 2
	lastlocal = idlocal_tbl
end
;
; Parser
;
def parse_term
	when scan
		is ID_TKN
			return TRUE
		is INT_TKN
			return TRUE
		is CHR_TKN
			return TRUE
		is STR_TKN
			return TRUE
		is OPEN_PAREN_TKN
			if !parse_expr
				return FALSE
			fin
			if token <> CLOSE_PAREN_TKN
				return parse_err(@no_close_paren)
			fin
			return TRUE
	wend
	return FALSE
end
def parse_constval(valptr, sizeptr)
	byte mod, type
	word idptr

	mod			= 0
	type		= 0
	*valptr = 0
	while !parse_term
		when token
			is SUB_TKN
				mod = mod ? 1
			is COMP_TKN
				mod = mod ? 2
			is LOGIC_NOT_TKN
				mod = mod ? 4
			is AT_TKN
				mod = mod ? 8
			otherwise
				return 0
		wend
	loop
	when token
		is STR_TKN
			*valptr	 = constval
			^sizeptr = tknlen - 1
			type		 = STR_TYPE
			if mod
				return parse_err(@bad_op)
			fin
		is CHR_TKN
			*valptr	 = constval
			^sizeptr = 1
			type		 = BYTE_TYPE
		is INT_TKN
			*valptr	 = constval
			^sizeptr = 2
			type		 = WORD_TYPE
		is ID_TKN
			^sizeptr = 2
			idptr = id_lookup(tknptr, tknlen)
			if !idptr
				return parse_err(@bad_cnst)
			fin
            type    = (idptr).idtype
            *valptr = (idptr):idval
			if type & VAR_TYPE and !(mod & 8)
				return parse_err(@bad_cnst)
			fin
		otherwise
			return parse_err(@bad_cnst)
	wend
	if mod & 1
		*valptr = -*valptr
	fin
	if mod & 2
		*valptr = #*valptr
	fin
	if mod & 4
		*valptr = !*valptr
	fin
	return type
end
deft ispostop
	scan
	when token
		is OPEN_PAREN_TKN
			return TRUE
		is OPEN_BRACKET_TKN
			return TRUE
		is DOT_TKN
			return TRUE
		is COLON_TKN
			return TRUE
	wend
	return FALSE
end
def parse_value(rvalue)
	byte cparams, deref, type, emit_val
	word optos, idptr, value
	byte elem_type, elem_size
	word elem_offset

	deref		 = rvalue
	optos		 = opsp
	type		 = 0
	emit_val = FALSE
	value		 = 0

	;
	; Parse pre-ops
	;
	while !parse_term
		when token
			is ADD_TKN
			is BPTR_TKN
				if deref
					push_op(token, 0)
				else
					type = type ? BPTR_TYPE
					deref = deref + 1
				fin
			is WPTR_TKN
				if deref
					push_op(token, 0)
				else
					type = type ? WPTR_TYPE
					deref = deref + 1
				fin
			is AT_TKN
				deref = deref - 1
			is SUB_TKN
				push_op(token, 0)
			is COMP_TKN
				push_op(token, 0)
			is LOGIC_NOT_TKN
				push_op(token, 0)
			otherwise
				return 0
		wend
	loop
	;
	; Determine terminal type
	;
	when token
		is INT_TKN
			type  = type ? CONST_TYPE
			value = constval
		is CHR_TKN
			type  = type ? CONST_TYPE
			value = constval
		is ID_TKN
			idptr = id_lookup(tknptr, tknlen)
			if !idptr
			    return 0
			fin
			if !(idptr).idtype
				return 0
			fin
			type  = type ? (idptr).idtype
			value = (idptr):idval
		is CLOSE_PAREN_TKN
			type     = type ? WORD_TYPE
			emit_val = TRUE
		otherwise
			return 0
	wend
	;
	; Constant optimizations
	;
	if type & CONST_TYPE
		cparams = TRUE
		while optos < opsp and cparams
			when tos_op
				is NEG_TKN
					pop_op
					value = -value
				is COMP_TKN
					pop_op
					value = #value
				is LOGIC_NOT_TKN
					pop_op
					value = !value
				otherwise
					cparams = FALSE
			wend
		loop
	fin
	;
	; Parse post-ops
	;
	while ispostop
		if token == OPEN_BRACKET_TKN
			;
			; Array
			;
			if !emit_val
				if type & ADDR_TYPE
					if type & LOCAL_TYPE
						emit_localaddr(value)
					else
						emit_globaladdr(value)
					fin
				elsif type & CONST_TYPE
					emit_const(value)
				fin
				emit_val = TRUE
			fin ; !emit_val
			if type & PTR_TYPE
				emit_lw
			fin
			if !parse_expr
				return 0
			fin
			if token <> CLOSE_BRACKET_TKN
				return parse_err(@no_close_bracket)
			fin
			if type & WORD_TYPE
				type = WPTR_TYPE
				emit_indexword
			else
				type = BPTR_TYPE
				emit_indexbyte
			fin
		elsif token == DOT_TKN or token == COLON_TKN
			;
			; Dot and Colon
			;
			if token == DOT_TKN
				elem_type = BPTR_TYPE
			else
				elem_type = WPTR_TYPE
			fin
			if parse_constval(@elem_offset, @elem_size)
				;
				; Constant structure offset
				;
				if !emit_val
					if type & VAR_TYPE
						if type & LOCAL_TYPE
							emit_localaddr(value + elem_offset)
						else
							; emit_globaladdr(value + elem_offset)
							emit_globaladdr(value)
    						emit_const(elem_offset)
	    					emit_binaryop(ADD_TKN)
						fin
					elsif type & CONST_TYPE
						value = value + elem_offset
						emit_const(value)
					else ; FUNC_TYPE
                        emit_globaladdr(value)
						emit_const(elem_offset)
						emit_binaryop(ADD_TKN)
					fin
					emit_val = TRUE
				else
					if elem_offset <> 0
						emit_const(elem_offset)
						emit_binaryop(ADD_TKN)
					fin
				fin ; !emit_val
			elsif token == OPEN_BRACKET_TKN
				;
				; Array of arrays
				;
				if !emit_val
					if type & ADDR_TYPE
						if type & LOCAL_TYPE
							emit_localaddr(value)
						else
							emit_globaladdr(value)
						fin
					elsif type & CONST_TYPE
						emit_const(value)
					fin
					emit_val = TRUE
				fin ; !emit_val
				while parse_expr
					if token <> COMMA_TKN
						break
					fin
					emit_indexword
					emit_lw
				loop
				if token <> CLOSE_BRACKET_TKN
					return parse_err(@no_close_bracket)
				fin
				if elem_type & WPTR_TYPE
					emit_indexword
				else
					emit_indexbyte
				fin
			else
				return parse_err(@bad_offset)
			fin
			type = elem_type
		elsif token == OPEN_PAREN_TKN
			;
			; Function call
			;
			if !emit_val and type & VAR_TYPE
				if type & LOCAL_TYPE
					emit_localaddr(value)
				else
					emit_globaladdr(value)
				fin
			fin
                        if !(type & FUNC_CONST_TYPE)
                                emit_push
                        fin
			cparams = 0
			while parse_expr
				cparams = cparams + 1
				if token <> COMMA_TKN
					break
				fin
			loop
			if token <> CLOSE_PAREN_TKN
				return parse_err(@no_close_paren)
			fin
			if type & FUNC_CONST_TYPE
				emit_call(value, cparams)
			else
                                emit_pull
				emit_ical(cparams)
			fin
			emit_val = TRUE
			type = WORD_TYPE
		fin
	loop
	if emit_val
		if rvalue
			if deref and type & PTR_TYPE
				if type & BPTR_TYPE
					emit_lb
				else
					emit_lw
				fin
			fin
		fin
	else ; emit_val
		if type & CONST_TYPE
			emit_const(value)
		elsif deref
			if type & FUNC_TYPE
				emit_call(value, 0)
			elsif type & VAR_TYPE
				if type & LOCAL_TYPE
					if type & BYTE_TYPE
						emit_llb(value)
					else
						emit_llw(value)
					fin
				else
					if type & BYTE_TYPE
						emit_lab(value)
					else
						emit_law(value)
					fin
				fin
			elsif type & PTR_TYPE
				if type & BPTR_TYPE
					emit_lb
				else
					emit_lw
				fin
			fin
		else
			if type & LOCAL_TYPE
				emit_localaddr(value)
			else
				emit_globaladdr(value)
			fin
		fin
	fin ; emit_val
	while optos < opsp
		if !emit_unaryop(pop_op)
			return parse_err(@bad_op)
		fin
	loop
	return type
end
def parse_constexpr(valptr, sizeptr)
	byte type, size1, size2
	word val1, val2

	type = parse_constval(@val1, @size1)
	if !type
		return 0
	fin
	size2 = 0
	when scan
		is ADD_TKN
			type = parse_constval(@val2, @size2)
			if !type
				return 0
			fin
			*valptr = val1 + val2
		is SUB_TKN
			type = parse_constval(@val2, @size2)
			if !type
				return 0
			fin
			*valptr = val1 - val2
		is MUL_TKN
			type = parse_constval(@val2, @size2)
			if !type
				return 0
			fin
			*valptr = val1 * val2
		is DIV_TKN
			type = parse_constval(@val2, @size2)
			if !type
				return 0
			fin
			*valptr = val1 + val2
		is MOD_TKN
			type = parse_constval(@val2, @size2)
			if !type
				return 0
			fin
			*valptr = val1 % val2
		is AND_TKN
			type = parse_constval(@val2, @size2)
			if !type
				return 0
			fin
			*valptr = val1 & val2
		is OR_TKN
			type = parse_constval(@val2, @size2)
			if !type
				return 0
			fin
			*valptr = val1 ? val2
		is EOR_TKN
			type = parse_constval(@val2, @size2)
			if !type
				return 0
			fin
			*valptr = val1 ^ val2
		otherwise
			*valptr = val1
	wend
	if size1 > size2
		^sizeptr = size1
	else
		^sizeptr = size2
	fin
	return type
end
def parse_expr
	byte prevmatch, matchop, i
	word optos

	matchop = 0
	optos   = opsp
	repeat
		prevmatch = matchop
		matchop		= 0
		if parse_value(1)
			matchop = 1
			for i = 0 to bops_tblsz
				if token == bops_tbl[i]
					matchop = 2
					if bops_prec[i] >= tos_op_prec(optos)
						if !emit_binaryop(pop_op)
							return parse_err(@bad_op)
						fin
					fin
					push_op(token, bops_prec[i])
					break
				fin
			next
		fin
	until matchop <> 2
	if matchop == 0 and prevmatch == 2
		return parse_err(@missing_op)
	fin
	while optos < opsp
		if !emit_binaryop(pop_op)
			return parse_err(@bad_op)
		fin
	loop
	return matchop or prevmatch
end
def parse_stmnt
	byte type, i
	word tag_prevbrk, tag_else, tag_endif, tag_while, tag_wend
	word tag_repeat, tag_for, tag_choice, idptr, saveptr, addr, stepdir

	if token <> END_TKN and token <> DONE_TKN
		prevstmnt = token
	fin
	when token
		is IF_TKN
			if !parse_expr
				return 0
			fin
			tag_else	= ctag_new
			tag_endif = ctag_new
			emit_brfls(tag_else)
			scan
			repeat
				while parse_stmnt
					nextln
				loop
				if token <> ELSEIF_TKN
					break
				fin
				emit_jump(tag_endif)
				emit_codetag(tag_else)
				if !parse_expr
					return 0
				fin
				tag_else = ctag_new
				emit_brfls(tag_else)
			until FALSE
			if token == ELSE_TKN
				emit_jump(tag_endif)
				emit_codetag(tag_else)
				scan
				while parse_stmnt
					nextln
				loop
				emit_codetag(tag_endif)
			else
				emit_codetag(tag_else)
				emit_codetag(tag_endif)
			fin
			if token <> FIN_TKN
				return parse_err(@no_fin)
			fin
		is FOR_TKN
			stack_loop	= stack_loop + 1
			tag_for		= ctag_new
			tag_prevbrk = break_tag
			break_tag	= ctag_new
			if scan <> ID_TKN
				return parse_err(@bad_stmnt)
			fin
			idptr = id_lookup(tknptr, tknlen)
			if idptr
    			type  = (idptr).idtype
	    		addr  = (idptr):idval
	    	else
	    	    return FALSE
	    	fin
			if scan <> SET_TKN
				return parse_err(@bad_stmnt)
			fin
			if !parse_expr
				return parse_err(@bad_stmnt)
			fin
			emit_codetag(tag_for)
			if type & LOCAL_TYPE
				if type & BYTE_TYPE
					emit_dlb(addr)
				else
					emit_dlw(addr)
				fin
			else
				if type & BYTE_TYPE
					emit_dab(addr)
				else
					emit_daw(addr)
				fin
			fin
			if token == TO_TKN
				stepdir = 1
			elsif token == DOWNTO_TKN
				stepdir = -1
			else
				return parse_err(@bad_stmnt)
			fin
			if !parse_expr
				return parse_err(@bad_stmnt)
			fin
			if stepdir > 0
				emit_brgt(break_tag)
			else
				emit_brlt(break_tag)
			fin
			if token == STEP_TKN
				if !parse_expr
					return parse_err(@bad_stmnt)
				fin
				if stepdir > 0
					emit_binaryop(ADD_TKN)
				else
					emit_binaryop(SUB_TKN)
				fin
			else
				if stepdir > 0
					emit_unaryop(INC_TKN)
				else
					emit_unaryop(DEC_TKN)
				fin
			fin
			while parse_stmnt
				nextln
			loop
			if token <> NEXT_TKN
				return parse_err(@bad_stmnt)
			fin
			emit_jump(tag_for)
			emit_codetag(break_tag)
			emit_drop
			break_tag = tag_prevbrk
			stack_loop = stack_loop - 1
		is WHILE_TKN
			tag_while		= ctag_new
			tag_wend		= ctag_new
			tag_prevbrk = break_tag
			break_tag		= tag_wend
			emit_codetag(tag_while)
			if !parse_expr
				return 0
			fin
			emit_brfls(tag_wend)
			while parse_stmnt
				nextln
			loop
			if token <> LOOP_TKN
				return parse_err(@no_loop)
			fin
			emit_jump(tag_while)
			emit_codetag(tag_wend)
			break_tag = tag_prevbrk
		is REPEAT_TKN
			tag_repeat	= ctag_new
			tag_prevbrk = break_tag
			break_tag		= ctag_new
			emit_codetag(tag_repeat)
			scan
			while parse_stmnt
				nextln
			loop
			if token <> UNTIL_TKN
				return parse_err(@no_until)
			fin
			if !parse_expr
				return 0
			fin
			emit_brfls(tag_repeat)
			emit_codetag(break_tag)
			break_tag = tag_prevbrk
		is CASE_TKN
			stack_loop	= stack_loop + 1
			tag_choice	= ctag_new
			tag_prevbrk = break_tag
			break_tag		= ctag_new
			if !parse_expr
				return parse_err(@bad_stmnt)
			fin
			nextln
			while token <> ENDCASE_TKN
				when token
					is OF_TKN
						if !parse_expr
							return parse_err(@bad_stmnt)
						fin
						emit_brne(tag_choice)
						while parse_stmnt
							nextln
						loop
						emit_jump(break_tag)
						emit_codetag(tag_choice)
						tag_choice = ctag_new
					is DEFAULT_TKN
						scan
						while parse_stmnt
							nextln
						loop
						if token <> ENDCASE_TKN
							return parse_err(@bad_stmnt)
						fin
					otherwise
						return parse_err(@bad_stmnt)
				wend
			loop
			emit_codetag(break_tag)
			emit_drop
			break_tag = tag_prevbrk
			stack_loop = stack_loop - 1
		is BREAK_TKN
			if break_tag
				emit_jump(break_tag)
			else
				return parse_err(@bad_stmnt)
			fin
		is RETURN_TKN
			if infunc
				for i = 1 to stack_loop
					emit_drop
				next
				if !parse_expr
					emit_const(0)
				fin
                emit_leave(framesize)
			else
				return parse_err(@bad_stmnt)
			fin
		is EXIT_TKN
            if !parse_expr
                emit_const(0)
            fin
			emit_exit
		is ELSE_TKN
			return FALSE
		is ELSEIF_TKN
			return FALSE
		is FIN_TKN
			return FALSE
		is LOOP_TKN
			return FALSE
		is UNTIL_TKN
			return FALSE
		is NEXT_TKN
			return FALSE
		is OF_TKN
			return FALSE
		is DEFAULT_TKN
			return FALSE
		is ENDCASE_TKN
			return FALSE
		is END_TKN
			return FALSE
		is DONE_TKN
			return FALSE
		is IFUNC_TKN
			return FALSE
		is TFUNC_TKN
			return FALSE
		is NFUNC_TKN
			return FALSE
		is EOF_TKN
			return FALSE
		is EOL_TKN
			return TRUE
		otherwise
			if token == ID_TKN
				saveptr = tknptr
				idptr = id_lookup(tknptr, tknlen)
				if !idptr
				    return FALSE
				fin
				type = (idptr).idtype
				if type & ADDR_TYPE
					addr = (idptr):idval
					if scan == SET_TKN
						if type & VAR_TYPE
							if !parse_expr
								return parse_err(@bad_expr)
							fin
							if type & LOCAL_TYPE
								if type & BYTE_TYPE
									emit_slb(addr)
								else
									emit_slw(addr)
								fin
							else
								if type & BYTE_TYPE
									emit_sab(addr)
								else
									emit_saw(addr)
								fin
							fin
							return TRUE
						fin
					elsif token == EOL_TKN and type & FUNC_TYPE
						emit_call(addr, 0)
						emit_drop
						return TRUE
					fin
				fin
				tknptr = saveptr
			fin
			rewind(tknptr)
			type = parse_value(0)
			if type
				if token == SET_TKN
					if !parse_expr
						return parse_err(@bad_expr)
					fin
					if type & XBYTE_TYPE
						emit_sb
					else
						emit_sw
					fin
				else
					if type & BPTR_TYPE
						emit_lb
					elsif type & WPTR_TYPE
						emit_lw
					fin
					emit_drop
				fin
			else
				return parse_err(@bad_syntax)
			fin
	wend
	if scan <> EOL_TKN
		return parse_err(@bad_syntax)
	fin
	return TRUE
end
def parse_var(type)
	byte consttype, constsize, idlen
	word idptr, constval, arraysize, size

	idlen = 0
	size  = 1
	if scan == ID_TKN
		idptr = tknptr
		idlen = tknlen
		if scan == OPEN_BRACKET_TKN
			size = 0
			parse_constexpr(@size, @constsize)
			if token <> CLOSE_BRACKET_TKN
				return parse_err(@no_close_bracket)
			fin
			scan
		fin
	fin
	if type == WORD_TYPE
		size = size * 2
	fin
	if token == SET_TKN
		if infunc
			return parse_err(@no_local_init)
		fin
		if idlen
			iddata_add(idptr, idlen, type, 0)
		fin
		consttype = parse_constexpr(@constval, @constsize)
		if consttype
			arraysize = emit_data(type, consttype, constval, constsize)
			while token == COMMA_TKN
				consttype = parse_constexpr(@constval, @constsize)
				if consttype
					arraysize = arraysize + emit_data(type, consttype, constval, constsize)
				else
					return parse_err(@bad_decl)
				fin
			loop
			if token <> EOL_TKN
				return parse_err(@no_close_bracket)
			fin
			iddata_size(PTR_TYPE, size, arraysize);
		else
			return parse_err(@bad_decl)
		fin
	elsif idlen
		if infunc
			idlocal_add(idptr, idlen, type, size)
		else
			iddata_add(idptr, idlen, type, size)
		fin
	fin
	return TRUE
end
def parse_vars
	byte idlen, type, size
	word value, idptr

	when token
		is CONST_TKN
			if scan <> ID_TKN
				return parse_err(@bad_cnst)
			fin
			idptr = tknptr;
			idlen = tknlen
			if scan <> SET_TKN
				return parse_err(@bad_cnst)
			fin
			if !parse_constexpr(@value, @size)
				return parse_err(@bad_cnst)
			fin
			idconst_add(idptr, idlen, value)
		is BYTE_TKN
			type = BYTE_TYPE
			repeat
				if !parse_var(type)
					return FALSE
				fin
			until token <> COMMA_TKN
		is WORD_TKN
			type = WORD_TYPE
			repeat
				if !parse_var(type)
					return FALSE
				fin
			until token <> COMMA_TKN
		is FUNC_TKN
			repeat
				if scan == ID_TKN
					idfunc_add(tknptr, tknlen, ctag_new)
				else
					return parse_err(@bad_decl)
				fin
			until scan <> COMMA_TKN
		is EOL_TKN
			return TRUE
		otherwise
			return FALSE
	wend
	return TRUE
end
def parse_func
	byte defopt, cfnparms
	word func_tag, idptr

	if token == IFUNC_TKN or token == TFUNC_TKN or token == NFUNC_TKN
		defopt = token - IFUNC_TKN
		if scan <> ID_TKN
			return parse_err(@bad_decl)
		fin
		cfnparms = 0
		infunc	 = TRUE
		idptr = idglobal_lookup(tknptr, tknlen)
		if idptr
			func_tag = (idptr):idval
		else
			func_tag = ctag_new
			idfunc_add(tknptr, tknlen, func_tag)
		fin
		emit_codetag(func_tag)
		retfunc_tag = ctag_new
		idlocal_init
		if scan == OPEN_PAREN_TKN
		  repeat
        if scan == ID_TKN
          cfnparms = cfnparms + 1
          idlocal_add(tknptr, tknlen, WORD_TYPE, 2)
          scan
        fin
			until token <> COMMA_TKN
			if token <> CLOSE_PAREN_TKN
				return parse_err(@bad_decl)
			fin
			scan
		fin
		while parse_vars
			nextln
		loop
        emit_enter(framesize, cfnparms)
		prevstmnt = 0
		while parse_stmnt
			nextln
		loop
		infunc = FALSE
		if token <> END_TKN
			return parse_err(@bad_syntax)
		fin
		if scan <> EOL_TKN
			return parse_err(@bad_syntax)
		fin
		if prevstmnt <> RETURN_TKN
			emit_const(0)
			emit_leave(framesize)
		fin
		return TRUE
	elsif token == EOL_TKN
		return TRUE
	fin
	return FALSE
end
def parse_module
    entrypoint = 0
    idglobal_init
    idlocal_init
	if nextln
		while parse_vars
			nextln
		loop
		while parse_func
			nextln
		loop
		if token <> DONE_TKN
			emit_start
			prevstmnt = 0
			while parse_stmnt
				nextln
			loop
			if token <> DONE_TKN
				parse_err(@no_done)
			fin
			if prevstmnt <> EXIT_TKN
                emit_const(0)
				emit_exit
			fin
		fin
		; dumpsym(idglobal_tbl, globals)
		; prstr(@entrypt_str)
		; prword(entrypoint)
		; crout
		; keyin()
		return TRUE
	fin
	return FALSE
end
;
; Init editor
;
if !(^machid & $80)
    flags = uppercase ? shiftlock
    keyin = @keyin2
else
    keyin = @keyin2e
fin
inittxtbuf
if ^argbuff
    strcpy(argbuff, @txtfile)
    prstr(@txtfile)
    readtxt(@txtfile)
else
    numlines = 1
fin
curschr  = '+'
flags = flags ? insmode
drawscrn(scrntop, scrnleft)
curson
editmode
done