Apple-2-Tools
/
VM02
mirror of https://github.com/dschmenk/VM02.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity
VM02/plasma2/plide.pla

3846 lines
93 KiB
Plaintext
Executable File
Raw Permalink Blame History

;
; Global constants
;
const FALSE = 0
const TRUE = !FALSE
;
; 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 ][ IDE VERSION 0.8 "
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_01
;
; 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 SETLIST_TKN = $B9 ; =,
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 NFUNC_TKN = $96
const DROP_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 = "DROP", DROP_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 = "DEFOPT", NFUNC_TKN
byte = "RETURN", RETURN_TKN
byte = $FF
;
; Mathematical ops
;
const bops_tblsz = 18 ; 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
byte = COMMA_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
byte = 11
; 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 messages
;
byte brkmsg[] = "CTRL-C BREAK"
byte stkovflwmsg[] = "STACK OVERFLOW/UNDERFLOW ERROR"
;
; 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_01, parse_module_01
;
; Utility functions
;
; Defines for ASM routines
;
asm equates
TMP EQU $F0
TMPL EQU TMP
TMPH EQU TMP+1
SRC EQU TMP
SRCL EQU SRC
SRCH EQU SRC+1
DST EQU SRC+2
DSTL EQU DST
DSTH EQU DST+1
ESP EQU DST+2
SAVEESP EQU ESP+1
SAVESP EQU SAVEESP+1
SAVEFP EQU SAVESP+1
SAVETMR EQU SAVEFP+2
SAVEINT EQU SAVETMR+2
TMRVEC EQU $03E8
INTVEC EQU $03EA
JMPTMP: JMP (TMP)
STKOVFLW:
LDY #$02
JMP EXECRET
BRKCHK:
LDA $C000
CMP #$83 ; CTRL-C
BNE :+
BIT $C010
LDY #$01
JMP EXECRET
:
end
;
; ENTER MODULE UNDER TEST
;
asm execentry
LDA ESTKL,X
STA TMPL
LDA ESTKH,X
STA TMPH
STX SAVEESP
TSX
STX SAVESP
LDA FRMPL
STA SAVEFP
LDA FRMPH
STA SAVEFP+1
LDA TMRVEC
STA SAVETMR
LDA TMRVEC+1
STA SAVETMR+1
LDA INTVEC
STA SAVEINT
LDA INTVEC+1
STA SAVEINT+1
LDA #<BRKCHK
STA TMRVEC
LDA #>BRKCHK
STA TMRVEC+1
LDA #<STKOVFLW
STA INTVEC
LDA #>STKOVFLW
STA INTVEC+1
LDX #ESTKSZ/2
JSR JMPTMP
LDY #$00
EXECRET:
STY TMP
BIT ROMIN
BIT $C054
BIT $C051
BIT $C058
JSR $FB39 ; SET TEXT MODE
BIT LCBNK2
LDA SAVEFP
STA FRMPL
LDA SAVEFP+1
STA FRMPH
LDA SAVETMR
STA TMRVEC
LDA SAVETMR+1
STA TMRVEC+1
LDA SAVEINT
STA INTVEC
LDA SAVEINT+1
STA INTVEC+1
LDX SAVESP
TXS
LDX SAVEESP
LDY TMP
STY ESTKL,X
LDY #$00
STY ESTKH,X
end
;
; CALL 6502 ROUTINE
; ROMCALL(AREG, XREG, YREG, STATUS, ADDR)
;
asm romcall
PHP
LDA ESTKL,X
STA TMPL
LDA ESTKH,X
STA TMPH
INX
LDA ESTKL,X
PHA
INX
LDA ESTKL,X
TAY
INX
LDA ESTKL+1,X
PHA
LDA ESTKL,X
INX
STX ESP
TAX
PLA
BIT ROMIN
PLP
JSR JMPTMP
PHP
BIT LCBNK2
STA REGVALS+0
STX REGVALS+1
STY REGVALS+2
PLA
STA REGVALS+3
LDX ESP
LDA #<REGVALS
LDY #>REGVALS
STA ESTKL,X
STY ESTKH,X
PLP
RTS
REGVALS: DS 4
end
;
; CALL PRODOS
; SYSCALL(CMD, PARAMS)
;
asm syscall
LDA ESTKL,X
LDY ESTKH,X
STA PARAMS
STY PARAMS+1
INX
LDA ESTKL,X
STA CMD
STX ESP
JSR $BF00
CMD: DB 00
PARAMS: DW 0000
BIT LCBNK2
LDX ESP
STA ESTKL,X
LDY #$00
STY ESTKH,X
end
;
; SET MEMORY TO VALUE
; MEMSET(VALUE, ADDR, SIZE)
;
asm memset
LDY #$00
LDA ESTKL+1,X
STA DSTL
LDA ESTKH+1,X
STA DSTH
INC ESTKL,X
INC ESTKH,X
SETMEM: DEC ESTKL,X
BNE :+
DEC ESTKH,X
BEQ MEMEXIT
: LDA ESTKL+2,X
STA (DST),Y
INY
BNE :+
INC DSTH
: DEC ESTKL,X
BNE :+
DEC ESTKH,X
BEQ MEMEXIT
: LDA ESTKH+2,X
STA (DST),Y
INY
BNE SETMEM
INC DSTH
BNE SETMEM
MEMEXIT: INX
INX
INX
end
;
; COPY MEMORY
; MEMCPY(SRCADDR, DSTADDR, SIZE)
;
asm memcpy
LDY #$00
LDA ESTKL,X
BNE :+
LDA ESTKH,X
BEQ MEMEXIT
: LDA ESTKL+1,X
STA DSTL
LDA ESTKH+1,X
STA DSTH
LDA ESTKL+2,X
STA SRCL
LDA ESTKH+2,X
STA SRCH
CMP DSTH
BCC REVCPY
BNE FORCPY
LDA SRCL
CMP DSTL
BCS FORCPY
REVCPY: ; REVERSE DIRECTION COPY
; CLC
LDA ESTKL,X
ADC DSTL
STA DSTL
LDA ESTKH,X
ADC DSTH
STA DSTH
CLC
LDA ESTKL,X
ADC SRCL
STA SRCL
LDA ESTKH,X
ADC SRCH
STA SRCH
INC ESTKH,X
REVCPYLP:
LDA DSTL
BNE :+
DEC DSTH
: DEC DSTL
LDA SRCL
BNE :+
DEC SRCH
: DEC SRCL
LDA (SRC),Y
STA (DST),Y
DEC ESTKL,X
BNE REVCPYLP
DEC ESTKH,X
BNE REVCPYLP
BEQ MEMEXIT
FORCPY: INC ESTKH,X
FORCPYLP:
LDA (SRC),Y
STA (DST),Y
INC DSTL
BNE :+
INC DSTH
: INC SRCL
BNE :+
INC SRCH
: DEC ESTKL,X
BNE FORCPYLP
DEC ESTKH,X
BNE FORCPYLP
BEQ MEMEXIT
end
;
; CHAR OUT
; COUT(CHAR)
;
asm cout
LDA ESTKL,X
INX
ORA #$80
BIT ROMIN
JSR $FDED
BIT LCBNK2
end
;
; CHAR IN
; RDKEY()
;
asm cin
BIT ROMIN
STX ESP
JSR $FD0C
LDX ESP
BIT LCBNK2
DEX
AND #$7F
STA ESTKL,X
LDY #$00
STY ESTKH,X
end
;
; PRINT STRING
; PRSTR(STR)
;
asm prstr
LDY #$00
LDA ESTKL,X
STA SRCL
LDA ESTKH,X
STA SRCH
BIT ROMIN
LDA (SRC),Y
STA ESTKL,X
BEQ :+
_PRS1: INY
LDA (SRC),Y
ORA #$80
JSR $FDED
TYA
CMP ESTKL,X
BNE _PRS1
: INX
BIT LCBNK2
end
;
; READ STRING
; STR = RDSTR(PROMPTCHAR)
;
asm rdstr
LDA ESTKL,X
STA $33
STX ESP
BIT ROMIN
JSR $FD6A
BIT LCBNK2
STX $01FF
: LDA $01FF,X
AND #$7F
STA $01FF,X
DEX
BPL :-
LDX ESP
LDA #$FF
STA ESTKL,X
LDA #$01
STA ESTKH,X
end
;
; EXIT
;
asm exit
JSR $BF00
DB $65
DW EXITTBL
EXITTBL:
DB 4
DB 0
end
;
; ProDOS routines
;
def getpfx_11(path)
byte params[3]
^path = 0
params.0 = 1
params:1 = path
perr = syscall($C7, @params)
return path
end
def setpfx_11(path)
byte params[3]
params.0 = 1
params:1 = path
perr = syscall($C6, @params)
return path
end
def open_21(path, buff)
byte params[6]
params.0 = 3
params:1 = path
params:3 = buff
params.5 = 0
perr = syscall($C8, @params)
return params.5
end
def close_11(refnum)
byte params[2]
params.0 = 1
params.1 = refnum
perr = syscall($CC, @params)
return perr
end
def read_31(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_31(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_41(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_11(path)
byte params[12]
params.0 = 1
params:1 = path
perr = syscall($C1, @params)
return perr
end
def newline_31(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
cout($0D)
end
def bell
drop romcall(0, 0, 0, 0, $FBDD)
end
;
; Memory management routines
;
defopt strcpy_20(srcstr, dststr)
byte strlen
strlen = ^srcstr
while (srcstr).[strlen] == $8D or (srcstr).[strlen] == $A0
strlen = strlen - 1
loop
^dststr = strlen
memcpy(srcstr + 1, dststr + 1, strlen)
end
defopt heapaddr_21(ofst, mask)
word addr
addr = (ofst << 7) + strheap
while !(mask & 1)
addr = addr + 16
mask = mask >> 1
loop
return addr
end
defopt sizemask_11(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
return 0
end
defopt heapalloc_11(size)
byte szmask, i
word mapmask
szmask = sizemask_11(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_21(i, mapmask)
fin
until mapmask & $100
fin
next
bell()
prstr(@outofmem)
return 0
end
def freestr_10(strptr)
byte mask, ofst
if strptr and strptr <> @nullstr
mask = sizemask_11(^strptr + 1)
ofst = (strptr - strheap) >> 4
mask = mask << (ofst & $07)
ofst = ofst >> 3
strheapmap.[ofst] = strheapmap.[ofst] & #mask
fin
end
def newstr_11(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_11(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_11(chr)
if flags & uppercase
if chr & $E0 == $E0
chr = chr - $E0
fin
fin
return chr
end
def strupper_10(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_10(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_10(strlinbuf:[i])
next
end
def txtlower
word i, strptr
flags = flags & #uppercase
for i = numlines - 1 downto 0
strlower_10(strlinbuf:[i])
next
end
def prbyte_10(h)
cout('$')
drop romcall(h, 0, 0, 0, $FDDA)
end
def prword_10(h)
cout('$')
drop romcall(h >> 8, h, 0, 0, $F941)
end
def print_10(i)
byte numstr[7]
byte place, sign
place = 6
if i < 0
sign = 1
i = -i
else
sign = 0
fin
while i >= 10
i =, numstr[place] = i % 10 + '0'
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_30(namestr, len, strptr)
^strptr = len
memcpy(namestr, strptr + 1, len)
end
;def toupper_11(c)
; if c >= 'a'
; if c <= 'z'
; return c - $20
; fin
; fin
; return c
;end
asm toupper_11
LDA ESTKL,X
AND #$7F
CMP #'a'
BCC :+
CMP #'z'+1
BCS :+
SEC
SBC #$20
: STA ESTKL,X
end
asm clrhibit_10(strptr)
LDY #$02 ; strptr
LDA (FRMP),Y
STA SRCL
INY
LDA (FRMP),Y
STA SRCH
LDY #$00
LDA (SRC),Y
BEQ :+
TAY
CLHILP: LDA (SRC),Y
AND #$7F
STA (SRC),Y
DEY
BNE CLHILP
:
end
asm sethibit_10(strptr)
LDY #$02 ; strptr
LDA (FRMP),Y
STA SRCL
INY
LDA (FRMP),Y
STA SRCH
LDY #$00
LDA (SRC),Y
BEQ :+
TAY
STHILP: LDA (SRC),Y
ORA #$80
STA (SRC),Y
DEY
BNE STHILP
:
end
asm cpyln_20(srcstr, dststr)
LDY #$02 ; srcstr
LDA (FRMP),Y
STA SRCL
INY
LDA (FRMP),Y
STA SRCH
INY ; dststr
LDA (FRMP),Y
STA DSTL
INY
LDA (FRMP),Y
STA DSTH
LDY #$00
LDA (SRC),Y
TAY
LDA #$00
INY
STA (DST),Y
DEY
BEQ :++
CPLNLP: LDA (SRC),Y
CMP #$20
BCS :+
ADC #$60
: AND #$7F
STA (DST),Y
DEY
BNE CPLNLP
LDA (SRC),Y
: STA (DST),Y
end
;
; File routines
;
def readtxt_10(filename)
byte txtbuf[81], refnum, i, j
refnum = open_21(filename, iobuffer)
if refnum
drop newline_31(refnum, $7F, $0D)
repeat
txtbuf = read_31(refnum, @txtbuf + 1, maxlnlen)
if txtbuf
sethibit_10(@txtbuf)
if flags & uppercase
strupper_10(@txtbuf)
fin
strlinbuf:[numlines] = newstr_11(@txtbuf)
numlines = numlines + 1
fin
if !(numlines & $0F)
cout('.')
fin
until txtbuf == 0 or numlines == maxlines
drop close_11(refnum)
fin
if numlines == 0
numlines = 1
fin
end
def writetxt_10(filename)
byte txtbuf[81], refnum
byte j, chr
word i, strptr
drop destroy_11(filename)
drop create_41(filename, $C3, $04, $00) ; full access, TXT file
refnum = open_21(filename, iobuffer)
if refnum == 0
return
fin
for i = 0 to numlines - 1
cpyln_20(strlinbuf:[i], @txtbuf)
txtbuf = txtbuf + 1
txtbuf[txtbuf] = $0D
drop write_31(refnum, @txtbuf + 1, txtbuf)
if !(i & $0F)
cout('.')
fin
next
drop close_11(refnum)
end
;
; Screen routines
;
def clrscrn
drop romcall(0, 0, 0, 0, $FC58)
end
def drawrow_30(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
defopt drawscrn_20(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_20(scrntop, scrnleft)
curson()
end
def curshome
cursoff()
cursrow = 0
curscol = 0
cursx = 0
cursy = 0
scrnleft = 0
scrntop = 0
drawscrn_20(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_20(scrntop, scrnleft)
curson()
end
def cursup
if cursrow > 0
cursoff()
cursrow = cursrow - 1
if cursy > 0
cursy = cursy - 1
else
scrntop = cursrow
drawscrn_20(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_20(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_20(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_20(scrntop, scrnleft)
fin
curson()
fin
end
def pgright
byte i
for i = 7 downto 0
cursright()
next
end
;
; Keyboard routines
;
def keyin2e_01
repeat
cursflash()
until ^keyboard >= 128
return ^keystrobe
end
def keyin2_01
byte key
repeat
cursflash()
key = ^keyboard
if key == keyctrll
drop ^keystrobe
flags = flags ^ shiftlock
key = 0
fin
until key >= 128
drop ^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_10(slot)
byte txtbuf[80]
word i, scrncsw
scrncsw = *(csw)
*(csw) = $C000 ? (slot << 8)
for i = 0 to numlines - 1
cpyln_20(strlinbuf:[i], @txtbuf)
prstr(@txtbuf)
crout()
next
*(csw) = scrncsw
end
def openline_11(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_10(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_11(cutbuf)
numlines = numlines + 1
flags = flags ? changed
redraw()
else
bell()
fin
end
def joinline
byte joinstr[80], joinlen
if cursrow < numlines - 1
strcpy_20(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_10(strlinbuf:[cursrow])
strlinbuf:[cursrow] = newstr_11(@joinstr)
freestr_10(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_11(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_11(@splitstr)
memcpy(strlinbuf:[cursrow] + 1, @splitstr + 1, curscol)
splitstr = curscol
freestr_10(strlinbuf:[cursrow])
strlinbuf:[cursrow] = newstr_11(@splitstr)
fin
else
strlinbuf:[cursrow + 1] = strlinbuf:[cursrow]
strlinbuf:[cursrow] = @nullstr
fin
curscol = 0
cursx = 0
scrnleft = 0
redraw()
cursdown()
fin
end
def editkey_11(key)
if key >= keyspace
return 1
elsif key == keydelete
return 1
elsif key == keyctrld
return 1
elsif key == keyctrlr
return 1
fin
return 0
end
def editline_11(key)
byte editstr[80]
word undoline
if (editkey_11(key))
flags = flags ? changed
memset($A0A0, @editstr, 80)
strcpy_20(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_30(cursy, scrnleft, @editstr)
else
scrnleft = scrnleft - 1
drawscrn_20(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_11(key)
cursoff()
if cursx <= 39
drawrow_30(cursy, scrnleft, @editstr)
else
scrnleft = scrnleft + 1
cursx = 39
drawscrn_20(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_30(cursy, scrnleft, @editstr)
curson()
fin
elsif key == keyctrlr
strcpy_20(undoline, @editstr)
cursoff()
drawrow_30(cursy, scrnleft, @editstr)
curson()
fin
key = keyin_01()
until !editkey_11(key)
if editstr
strlinbuf:[cursrow] = newstr_11(@editstr)
else
strlinbuf:[cursrow] = @nullstr
fin
freestr_10(undoline)
fin
return key
end
def editmode
repeat
when editline_11(keyin_01())
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
drop openline_11(cursrow)
redraw()
is keyenter
if flags & insmode
splitline()
else
drop openline_11(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()
wend
until 0
end
;
; Command mode
;
def prfiles_11(optpath)
byte path[64]
byte refnum
byte firstblk
byte entrylen, entriesblk
byte i, type, len
word entry, filecnt
if ^optpath
strcpy_20(optpath, @path)
else
drop getpfx_11(@path)
prstr(@path)
crout()
fin
refnum = open_21(@path, iobuffer);
if perr
return perr
fin
firstblk = 1
repeat
if read_31(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
drop close_11(refnum)
crout()
return 0
end
def striplead_20(strptr, chr)
while ^strptr and ^(strptr + 1) == chr
memcpy(strptr + 2, strptr + 1, ^strptr)
^strptr = ^strptr - 1
loop
end
def parsecmd_11(strptr)
byte cmd
cmd = 0
striplead_20(strptr, ' ')
if ^strptr
cmd = ^(strptr + 1)
memcpy(strptr + 2, strptr + 1, ^strptr)
^strptr = ^strptr - 1
fin
if ^strptr
striplead_20(strptr, ' ')
fin
return cmd
end
def chkchng_01
if flags & changed
prstr(@losechng)
if toupper_11(keyin_01()) == 'N'
crout()
return 0
fin
crout()
fin
return 1
end
def exec
when execentry()
is 1
crout()
prstr(@brkmsg)
crout()
is 2
crout()
prstr(@stkovflwmsg)
crout()
wend
;
; Close all files
;
^$BFD8 = 0
drop close_11(0)
end
def quit
if chkchng_01()
exit
fin
end
def cmdmode
byte slot
word cmdptr
clrscrn();
prstr(@version)
crout()
while 1
prstr(@txtfile)
cmdptr = rdstr($BA)
when toupper_11(parsecmd_11(cmdptr))
is 'A'
readtxt_10(cmdptr)
flags = flags ? changed
is 'R'
if chkchng_01()
inittxtbuf()
strcpy_20(cmdptr, @txtfile)
readtxt_10(@txtfile)
entrypoint = 0
flags = flags & #changed
fin
is 'W'
if ^cmdptr
strcpy_20(cmdptr, @txtfile)
fin
writetxt_10(@txtfile)
if flags & changed
entrypoint = 0
fin
flags = flags & #changed
is 'Q'
quit()
is 'C'
drop prfiles_11(cmdptr)
is 'P'
drop setpfx_11(cmdptr)
is 'H'
if ^cmdptr
slot = cmdptr.1 - '0'
else
slot = 1
fin
printtxt_10(slot)
is 'E'
return
is 0
return
is 'N'
if chkchng_01()
inittxtbuf()
numlines = 1
strcpy_20(@untitled, @txtfile)
fin
is 'X'
if flags & changed or !entrypoint
drop parse_module_01()
if parserr
bell()
cursrow = parserrln
scrntop = cursrow & $FFF8
cursy = cursrow - scrntop
curscol = parserrpos
scrnleft = curscol & $FFE0
cursx = curscol - scrnleft
else
crout()
exec(entrypoint)
fin
else
exec(entrypoint)
fin
crout()
is 'V'
prstr(@version)
wend
if perr
prstr(@errorstr)
drop romcall(perr, 0, 0, 0, $FDDA)
else
prstr(@okstr)
fin
crout()
loop
end
;=====================================
;
; PLASMA Compiler
;
;=====================================
;
; Error handler
;
def parse_err_11(err)
if !parserr
parserr = TRUE
parserrln = lineno - 1
parserrpos = tknptr - inbuff
print_10(lineno)
cout(':')
prstr(err)
crout()
fin
return ERR_TKN
end
;
; Emit bytecode
;
def ctag_new_01
if codetag >= ctag_max
return parse_err_11(@ctag_full)
fin
codetag = codetag + 1
ctag_value:[codetag] = 0
ctag_flags.[codetag] = 0
return codetag ? is_ctag
end
defopt ctag_resolve_21(tag, addr)
word updtptr, nextptr
tag = tag & mask_ctag
if ctag_flags.[tag] & resolved
return parse_err_11(@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
return 0
end
defopt emit_byte_10(bval)
^codeptr = bval
codeptr = codeptr + 1
end
defopt emit_word_10(wval)
*codeptr = wval
codeptr = codeptr + 2
end
def emit_fill_10(size)
memset(0, codeptr, size)
codeptr = codeptr + size
end
def emit_codetag_10(tag)
drop ctag_resolve_21(tag, codeptr)
end
defopt emit_op_10(op)
lastop = op
^codeptr = op
codeptr = codeptr + 1
end
def emit_tag_10(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_10(updtptr)
else
emit_word_10(tag + codebuff)
fin
end
def emit_iddata_30(value, size, namestr)
emit_fill_10(size)
end
def emit_data_41(vartype, consttype, constval, constsize)
byte i
word size, chrptr
if consttype == 0
size = constsize
emit_fill_10(constsize)
elsif consttype == STR_TYPE
size = constsize
chrptr = constval
constsize = constsize - 1
emit_byte_10(constsize)
while constsize > 0
emit_byte_10(^chrptr)
chrptr = chrptr + 1
constsize = constsize - 1
loop
else
if vartype == WORD_TYPE
size = 2
emit_word_10(constval)
else
size = 1
emit_byte_10(constval)
fin
fin
return size
end
def emit_const_10(cval)
if cval == 0
emit_op_10($00)
elsif cval > 0 and cval < 256
emit_op_10($2A)
emit_byte_10(cval)
else
emit_op_10($2C)
emit_word_10(cval)
fin
end
def emit_lb
emit_op_10($60)
end
def emit_lw
emit_op_10($62)
end
def emit_llb_10(index)
emit_op_10($64)
emit_byte_10(index)
end
def emit_llw_10(index)
emit_op_10($66)
emit_byte_10(index)
end
def emit_lab_10(tag)
emit_op_10($68)
emit_tag_10(tag)
end
def emit_law_10(tag)
emit_op_10($6A)
emit_tag_10(tag)
end
def emit_sb
emit_op_10($70)
end
def emit_sw
emit_op_10($72)
end
def emit_slb_10(index)
emit_op_10($74)
emit_byte_10(index)
end
def emit_slw_10(index)
emit_op_10($76)
emit_byte_10(index)
end
def emit_dlb_10(index)
emit_op_10($6C)
emit_byte_10(index)
end
def emit_dlw_10(index)
emit_op_10($6E)
emit_byte_10(index)
end
def emit_sab_10(tag)
emit_op_10($78)
emit_tag_10(tag)
end
def emit_saw_10(tag)
emit_op_10($7A)
emit_tag_10(tag)
end
def emit_dab_10(tag)
emit_op_10($7C)
emit_tag_10(tag)
end
def emit_daw_10(tag)
emit_op_10($7E)
emit_tag_10(tag)
end
def emit_call_10(tag)
emit_op_10($54)
emit_tag_10(tag)
end
def emit_ical
emit_op_10($56)
end
def emit_push
emit_op_10($34)
end
def emit_pull
;
; Skip if last op was push
;
if lastop == $34
codeptr = codeptr - 1
lastop = $FF
else
emit_op_10($36)
fin
end
def emit_localaddr_10(index)
emit_op_10($28)
emit_byte_10(index)
end
def emit_globaladdr_10(tag)
emit_op_10($26)
emit_tag_10(tag)
end
def emit_indexbyte
emit_op_10($02)
end
def emit_indexword
emit_op_10($1E)
end
defopt emit_unaryop_11(op)
when op
is NEG_TKN
emit_op_10($10)
is COMP_TKN
emit_op_10($12)
is LOGIC_NOT_TKN
emit_op_10($20)
is INC_TKN
emit_op_10($0C)
is DEC_TKN
emit_op_10($0E)
is BPTR_TKN
emit_op_10($60)
is WPTR_TKN
emit_op_10($62)
otherwise
return FALSE
wend
return TRUE
end
defopt emit_binaryop_11(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_10(1) ; CB 1
emit_op_10($1A) ; SHL
else
emit_op_10($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_10(1) ; CB 1
emit_op_10($1C) ; SHR
else
emit_op_10($08)
fin
is MOD_TKN
emit_op_10($0A)
is ADD_TKN
;
; Replace ADD 1 with INCR
;
if lastop == $2A and ^(codeptr - 1) == 1 ; CB 1
codeptr = codeptr - 2
emit_op_10($0C) ; INC_OP
else
emit_op_10($02)
fin
is SUB_TKN
;
; Replace SUB 1 with DECR
;
if lastop == $2A and ^(codeptr - 1) == 1 ; CB 1
codeptr = codeptr - 2
emit_op_10($0E) ; DEC_OP
else
emit_op_10($04)
fin
is SHL_TKN
emit_op_10($1A)
is SHR_TKN
emit_op_10($1C)
is AND_TKN
emit_op_10($14)
is OR_TKN
emit_op_10($16)
is EOR_TKN
emit_op_10($18)
is EQ_TKN
emit_op_10($40)
is NE_TKN
emit_op_10($42)
is GE_TKN
emit_op_10($48)
is LT_TKN
emit_op_10($46)
is GT_TKN
emit_op_10($44)
is LE_TKN
emit_op_10($4A)
is LOGIC_OR_TKN
emit_op_10($22)
is LOGIC_AND_TKN
emit_op_10($24)
is COMMA_TKN
; Do nothing except move to next stanza in expression
otherwise
return FALSE
wend
return TRUE
end
def emit_brtru_10(tag)
emit_op_10($4E)
emit_tag_10(tag)
end
def emit_brfls_10(tag)
emit_op_10($4C)
emit_tag_10(tag)
end
def emit_brgt_10(tag)
emit_op_10($3A)
emit_tag_10(tag)
end
def emit_brlt_10(tag)
emit_op_10($38)
emit_tag_10(tag)
end
def emit_brne_10(tag)
emit_op_10($3E)
emit_tag_10(tag)
end
def emit_jump_10(tag)
emit_op_10($50)
emit_tag_10(tag)
end
def emit_drop
emit_op_10($30)
end
def emit_swap
emit_op_10($2E)
end
def emit_leave_10(framesize)
if framesize > 2
emit_op_10($5A)
else
emit_op_10($5C)
fin
end
def emit_enter_20(framesize, cparams)
emit_byte_10($20)
emit_byte_10($D0)
emit_byte_10($03)
if framesize > 2
emit_op_10($58)
emit_byte_10(framesize)
emit_byte_10(cparams)
fin
end
def emit_start
;
; Save address
;
entrypoint = codeptr
emit_byte_10(emit_start.[0])
emit_byte_10(emit_start.[1])
emit_byte_10(emit_start.[2])
end
def emit_exit
emit_op_10($00)
emit_op_10($5C)
end
;
; Lexical anaylzer
;
;def isalpha_11(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_11
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
;def isnum_11(c)
; if c >= '0' and c <= '9'
; return TRUE
; fin
; return FALSE
;end
asm isnum_11
LDY #$00
LDA ESTKL,X
CMP #'0'
BCC :+
CMP #'9'+1
BCS :+
DEY
: STY ESTKL,X
STY ESTKH,X
RTS
end
;def isalphanum_11(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_11
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 :+
CMP #'z'+1
BCS ISANRET
DEY
BNE ISANRET
: CMP #'_'
BNE ISANRET
DEY
ISANRET:
STY ESTKL,X
STY ESTKH,X
RTS
end
defopt keymatch_21(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_11((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
defopt skipspace_01
;
; Skip whitespace
;
while ^scanptr and ^scanptr <= ' '
scanptr = scanptr + 1
loop
tknptr = scanptr
return !^scanptr or ^scanptr == ';'
end
def scan_01
;
; Scan for token based on first character
;
if skipspace_01()
if token <> EOF_TKN
token = EOL_TKN
fin
elsif isalpha_11(^scanptr)
;
; ID, either variable name or reserved word
;
repeat
scanptr = scanptr + 1
until !isalphanum_11(^scanptr)
tknlen = scanptr - tknptr;
token = keymatch_21(tknptr, tknlen)
elsif isnum_11(^scanptr)
;
; Number constant
;
token = INT_TKN
constval = 0
repeat
constval = constval * 10 + ^scanptr - '0'
scanptr = scanptr + 1
until !isnum_11(^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_11(@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_11(@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_11(@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;
elsif ^(scanptr + 1) == ','
token = SETLIST_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_10(ptr)
scanptr = ptr
end
;
; Get next line of input
;
defopt nextln_01
; if ^keyboard == $A0
; ^keystrobe
; while ^keyboard < 128
; loop
; ^keystrobe
; elsif ^keyboard == $82
; lineno = numlines
; ^keystrobe
; fin
scanptr = inbuff
if lineno < numlines
cpyln_20(strlinbuf:[lineno], instr)
lineno = lineno + 1
if !(lineno & $0F)
cout('.')
fin
; cout('>')
; prstr(instr)
; crout()
drop scan_01()
else
^instr = 0
^inbuff = $00
token = DONE_TKN
fin
return ^instr
end
;
; Alebraic op to stack op
;
def push_op_21(op, prec)
opsp = opsp + 1
if opsp == 16
return parse_err_11(@estk_overflw)
fin
opstack[opsp] = op
precstack[opsp] = prec
return 0
end
def pop_op_01
if opsp < 0
return parse_err_11(@estk_underflw)
fin
opsp = opsp - 1
return opstack[opsp + 1]
end
def tos_op_01
if opsp < 0
return 0
fin
return opstack[opsp]
end
def tos_op_prec_11(tos)
if opsp <= tos
return 100
fin
return precstack[opsp]
end
;
; Symbol table
;
defopt idmatch_41(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_20(idptr, idcnt)
; while idcnt
; prword_10((idptr):idval)
; cout(' ')
; prbyte_10((idptr).idtype)
; cout(' ')
; prstr(@(idptr).idname)
; cout('=')
; if (idptr).idtype & ADDR_TYPE
; if (idptr):idval & is_ctag
; prword_10(ctag_value:[(idptr):idval & mask_ctag])
; else
; prword_10((idptr):idval + codebuff)
; fin
; else
; prword_10((idptr):idval)
; fin
; crout()
; idptr = idptr + (idptr).idname + idrecsz
; idcnt = idcnt - 1
; loop
;end
def id_lookup_21(nameptr, len)
word idptr
idptr = idmatch_41(nameptr, len, idlocal_tbl, locals)
if idptr
return idptr
fin
idptr = idmatch_41(nameptr, len, idglobal_tbl, globals)
if idptr
return idptr
fin
return parse_err_11(@undecl_id)
end
def idglobal_lookup_21(nameptr, len)
return idmatch_41(nameptr, len, idglobal_tbl, globals)
end
def idlocal_add_41(namestr, len, type, size)
if idmatch_41(namestr, len, @idlocal_tbl, locals)
return parse_err_11(@dup_id)
fin
(lastlocal):idval = framesize
(lastlocal).idtype = type ? LOCAL_TYPE
nametostr_30(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_41(namestr, len, type, size)
if idmatch_41(namestr, len, idglobal_tbl, globals)
return parse_err_11(@dup_id)
fin
(lastglobal):idval = datasize
(lastglobal).idtype = type
nametostr_30(namestr, len, lastglobal + idname)
emit_iddata_30(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_30(type, varsize, initsize)
if varsize > initsize
datasize = datasize + emit_data_41(0, 0, 0, varsize - initsize)
else
datasize = datasize + initsize
fin
; if datasize <> codeptr - codebuff
; prstr(@emiterr)
; keyin_01()
; fin
end
def idglobal_add_41(namestr, len, type, value)
if idmatch_41(namestr, len, idglobal_tbl, globals)
return parse_err_11(@dup_id)
fin
(lastglobal):idval = value
(lastglobal).idtype = type
nametostr_30(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_31(namestr, len, tag)
return idglobal_add_41(namestr, len, FUNC_TYPE, tag)
end
def idconst_add_31(namestr, len, value)
return idglobal_add_41(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_01()
drop idfunc_add_31(@runtime0 + 1, runtime0, ctag)
drop idfunc_add_31(@RUNTIME0 + 1, RUNTIME0, ctag)
drop ctag_resolve_21(ctag, @romcall)
ctag = ctag_new_01()
drop idfunc_add_31(@runtime1 + 1, runtime1, ctag)
drop idfunc_add_31(@RUNTIME1 + 1, RUNTIME1, ctag)
drop ctag_resolve_21(ctag, @syscall)
ctag = ctag_new_01()
drop idfunc_add_31(@runtime2 + 1, runtime2, ctag)
drop idfunc_add_31(@RUNTIME2 + 1, RUNTIME2, ctag)
drop ctag_resolve_21(ctag, @memset)
ctag = ctag_new_01()
drop idfunc_add_31(@runtime3 + 1, runtime3, ctag)
drop idfunc_add_31(@RUNTIME3 + 1, RUNTIME3, ctag)
drop ctag_resolve_21(ctag, @memcpy)
ctag = ctag_new_01()
drop idfunc_add_31(@runtime4 + 1, runtime4, ctag)
drop idfunc_add_31(@RUNTIME4 + 1, RUNTIME4, ctag)
drop ctag_resolve_21(ctag, @cout)
ctag = ctag_new_01()
drop idfunc_add_31(@runtime5 + 1, runtime5, ctag)
drop idfunc_add_31(@RUNTIME5 + 1, RUNTIME5, ctag)
drop ctag_resolve_21(ctag, @cin)
ctag = ctag_new_01()
drop idfunc_add_31(@runtime6 + 1, runtime6, ctag)
drop idfunc_add_31(@RUNTIME6 + 1, RUNTIME6, ctag)
drop ctag_resolve_21(ctag, @prstr)
ctag = ctag_new_01()
drop idfunc_add_31(@runtime7 + 1, runtime7, ctag)
drop idfunc_add_31(@RUNTIME7 + 1, RUNTIME7, ctag)
drop ctag_resolve_21(ctag, @rdstr)
end
def idlocal_init
locals = 0
framesize = 2
lastlocal = idlocal_tbl
end
;
; Parser
;
def parse_term_01
when scan_01()
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_01()
return FALSE
fin
if token <> CLOSE_PAREN_TKN
return parse_err_11(@no_close_paren)
fin
return TRUE
wend
return FALSE
end
def parse_constval_21(valptr, sizeptr)
byte mod, type
word idptr
mod = 0
type = 0
*valptr = 0
while !parse_term_01()
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_11(@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_21(tknptr, tknlen)
if !idptr
return parse_err_11(@bad_cnst)
fin
type = (idptr).idtype
*valptr = (idptr):idval
if type & VAR_TYPE and !(mod & 8)
return parse_err_11(@bad_cnst)
fin
otherwise
return parse_err_11(@bad_cnst)
wend
if mod & 1
*valptr = -*valptr
fin
if mod & 2
*valptr = #*valptr
fin
if mod & 4
*valptr = !*valptr
fin
return type
end
def ispostop_01
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_11(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 = 0
value = 0
;
; Parse pre-ops
;
while !parse_term_01()
when token
is ADD_TKN
is BPTR_TKN
if deref
drop push_op_21(token, 0)
else
type = type ? BPTR_TYPE
deref = deref + 1
fin
is WPTR_TKN
if deref
drop push_op_21(token, 0)
else
type = type ? WPTR_TYPE
deref = deref + 1
fin
is AT_TKN
deref = deref - 1
is SUB_TKN
drop push_op_21(token, 0)
is COMP_TKN
drop push_op_21(token, 0)
is LOGIC_NOT_TKN
drop push_op_21(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_21(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 = 1
otherwise
return 0
wend
;
; Constant optimizations
;
if type & CONST_TYPE
cparams = TRUE
while optos < opsp and cparams
when tos_op_01()
is NEG_TKN
drop pop_op_01()
value = -value
is COMP_TKN
drop pop_op_01()
value = #value
is LOGIC_NOT_TKN
drop pop_op_01()
value = !value
otherwise
cparams = FALSE
wend
loop
fin
;
; Parse post-ops
;
drop scan_01()
while ispostop_01()
if token == OPEN_BRACKET_TKN
;
; Array
;
if !emit_val
if type & ADDR_TYPE
if type & LOCAL_TYPE
emit_localaddr_10(value)
else
emit_globaladdr_10(value)
fin
elsif type & CONST_TYPE
emit_const_10(value)
fin
emit_val = 1
fin ; !emit_val
if type & PTR_TYPE
emit_lw()
fin
if !parse_expr_01()
return 0
fin
if token <> CLOSE_BRACKET_TKN
return parse_err_11(@no_close_bracket)
fin
if type & WORD_TYPE
type = WPTR_TYPE
emit_indexword()
else
type = BPTR_TYPE
emit_indexbyte()
fin
drop scan_01()
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_21(@elem_offset, @elem_size)
;
; Constant structure offset
;
if !emit_val
if type & VAR_TYPE
if type & LOCAL_TYPE
emit_localaddr_10(value + elem_offset)
else
; emit_globaladdr_10(value + elem_offset)
emit_globaladdr_10(value)
emit_const_10(elem_offset)
drop emit_binaryop_11(ADD_TKN)
fin
elsif type & CONST_TYPE
value = value + elem_offset
emit_const_10(value)
else ; FUNC_TYPE
emit_globaladdr_10(value)
emit_const_10(elem_offset)
drop emit_binaryop_11(ADD_TKN)
fin
emit_val = 1
else
if elem_offset <> 0
emit_const_10(elem_offset)
drop emit_binaryop_11(ADD_TKN)
fin
fin ; !emit_val
drop scan_01()
elsif token == OPEN_BRACKET_TKN
;
; Array of arrays
;
if !emit_val
if type & ADDR_TYPE
if type & LOCAL_TYPE
emit_localaddr_10(value)
else
emit_globaladdr_10(value)
fin
elsif type & CONST_TYPE
emit_const_10(value)
fin
emit_val = 1
fin ; !emit_val
repeat
if emit_val > 1
emit_indexword()
emit_lw()
fin
emit_val = emit_val + 1
if !parse_expr_01()
return parse_err_11(@bad_expr)
fin
if token <> CLOSE_BRACKET_TKN
return parse_err_11(@no_close_bracket)
fin
until scan_01() <> OPEN_BRACKET_TKN
if elem_type & WPTR_TYPE
emit_indexword()
else
emit_indexbyte()
fin
else
return parse_err_11(@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_10(value)
else
emit_globaladdr_10(value)
fin
fin
if !(type & FUNC_CONST_TYPE)
emit_push()
fin
drop parse_expr_01()
if token <> CLOSE_PAREN_TKN
return parse_err_11(@no_close_paren)
fin
if type & FUNC_CONST_TYPE
emit_call_10(value)
else
emit_pull()
emit_ical()
fin
emit_val = 1
type = WORD_TYPE
drop scan_01()
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_10(value)
elsif deref
if type & FUNC_TYPE
emit_call_10(value)
elsif type & VAR_TYPE
if type & LOCAL_TYPE
if type & BYTE_TYPE
emit_llb_10(value)
else
emit_llw_10(value)
fin
else
if type & BYTE_TYPE
emit_lab_10(value)
else
emit_law_10(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_10(value)
else
emit_globaladdr_10(value)
fin
fin
fin ; emit_val
while optos < opsp
if !emit_unaryop_11(pop_op_01())
return parse_err_11(@bad_op)
fin
loop
return type
end
def parse_constexpr_21(valptr, sizeptr)
byte type, size1, size2
word val1, val2
type = parse_constval_21(@val1, @size1)
if !type
return 0
fin
size2 = 0
when scan_01()
is ADD_TKN
type = parse_constval_21(@val2, @size2)
if !type
return 0
fin
*valptr = val1 + val2
is SUB_TKN
type = parse_constval_21(@val2, @size2)
if !type
return 0
fin
*valptr = val1 - val2
is MUL_TKN
type = parse_constval_21(@val2, @size2)
if !type
return 0
fin
*valptr = val1 * val2
is DIV_TKN
type = parse_constval_21(@val2, @size2)
if !type
return 0
fin
*valptr = val1 + val2
is MOD_TKN
type = parse_constval_21(@val2, @size2)
if !type
return 0
fin
*valptr = val1 % val2
drop
is AND_TKN
type = parse_constval_21(@val2, @size2)
if !type
return 0
fin
*valptr = val1 & val2
is OR_TKN
type = parse_constval_21(@val2, @size2)
if !type
return 0
fin
*valptr = val1 ? val2
is EOR_TKN
type = parse_constval_21(@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_01
byte prevmatch, matchop, i
word optos
matchop = 0
optos = opsp
repeat
prevmatch = matchop
matchop = 0
if parse_value_11(1)
matchop = 1
for i = 0 to bops_tblsz
if token == bops_tbl[i]
matchop = 2
if bops_prec[i] >= tos_op_prec_11(optos)
if !emit_binaryop_11(pop_op_01())
return parse_err_11(@bad_op)
fin
fin
drop push_op_21(token, bops_prec[i])
break
fin
next
fin
until matchop <> 2
if matchop == 0 and prevmatch == 2
return parse_err_11(@missing_op)
fin
while optos < opsp
if !emit_binaryop_11(pop_op_01())
return parse_err_11(@bad_op)
fin
loop
return matchop or prevmatch
end
def parse_setlist_21(addr, type)
word nexttype, nextaddr, idptr, saveptr
if !(type & VAR_TYPE)
emit_push()
fin
nexttype = 0
nextaddr = 0
if scan_01() == ID_TKN
idptr = id_lookup_21(tknptr, tknlen)
if !idptr
return FALSE
fin
nexttype = (idptr).idtype
if type & VAR_TYPE
nextaddr = (idptr):idval
fin
fin
saveptr = tknptr
drop scan_01()
if nexttype & VAR_TYPE and token == SET_TKN
drop parse_expr_01()
if type & LOCAL_TYPE
if type & BYTE_TYPE
emit_slb_10(nextaddr)
else
emit_slw_10(nextaddr)
fin
else
if type & BYTE_TYPE
emit_sab_10(nextaddr)
else
emit_saw_10(nextaddr)
fin
fin
elsif nexttype & VAR_TYPE and token == SETLIST_TKN
if !parse_setlist_21(nextaddr, nexttype)
return FALSE
fin
else
tknptr = saveptr
rewind_10(tknptr)
nexttype = parse_value_11(0)
if nexttype <> 0
if token == SET_TKN
emit_push()
drop parse_expr_01()
emit_pull()
emit_swap()
if nexttype & (BYTE_TYPE ? BPTR_TYPE)
emit_sb()
else
emit_sw()
fin
fin
elsif token == SETLIST_TKN
if !parse_setlist_21(0, nexttype)
return FALSE
fin
else
return parse_err_11(@bad_syntax)
fin
fin
if type & VAR_TYPE
if type & LOCAL_TYPE
if type & BYTE_TYPE
emit_slb_10(addr)
else
emit_slw_10(addr)
fin
else
if type & BYTE_TYPE
emit_sab_10(addr)
else
emit_saw_10(addr)
fin
fin
else
emit_pull()
emit_swap()
if type & (BYTE_TYPE ? BPTR_TYPE)
emit_sb()
else
emit_sw()
fin
fin
return TRUE
end
def parse_stmnt_01
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
drop parse_expr_01()
tag_else = ctag_new_01()
tag_endif = ctag_new_01()
emit_brfls_10(tag_else)
drop scan_01()
repeat
while parse_stmnt_01()
drop nextln_01()
loop
if token <> ELSEIF_TKN
break
fin
emit_jump_10(tag_endif)
emit_codetag_10(tag_else)
if !parse_expr_01()
return 0
fin
tag_else = ctag_new_01()
emit_brfls_10(tag_else)
until FALSE
if token == ELSE_TKN
emit_jump_10(tag_endif)
emit_codetag_10(tag_else)
drop scan_01()
while parse_stmnt_01()
drop nextln_01()
loop
emit_codetag_10(tag_endif)
else
emit_codetag_10(tag_else)
emit_codetag_10(tag_endif)
fin
if token <> FIN_TKN
return parse_err_11(@no_fin)
fin
is FOR_TKN
stack_loop = stack_loop + 1
tag_for = ctag_new_01()
tag_prevbrk = break_tag
break_tag = ctag_new_01()
if scan_01() <> ID_TKN
return parse_err_11(@bad_stmnt)
fin
idptr = id_lookup_21(tknptr, tknlen)
if idptr
type = (idptr).idtype
addr = (idptr):idval
else
return FALSE
fin
if scan_01() <> SET_TKN
return parse_err_11(@bad_stmnt)
fin
if !parse_expr_01()
return parse_err_11(@bad_stmnt)
fin
emit_codetag_10(tag_for)
if type & LOCAL_TYPE
if type & BYTE_TYPE
emit_dlb_10(addr)
else
emit_dlw_10(addr)
fin
else
if type & BYTE_TYPE
emit_dab_10(addr)
else
emit_daw_10(addr)
fin
fin
stepdir = 1
if token == TO_TKN
drop parse_expr_01()
elsif token == DOWNTO_TKN
drop parse_expr_01()
stepdir = -1
fin
if stepdir > 0
emit_brgt_10(break_tag)
else
emit_brlt_10(break_tag)
fin
if token == STEP_TKN
drop parse_expr_01()
if stepdir > 0
drop emit_binaryop_11(ADD_TKN)
else
drop emit_binaryop_11(SUB_TKN)
fin
else
if stepdir > 0
drop emit_unaryop_11(INC_TKN)
else
drop emit_unaryop_11(DEC_TKN)
fin
fin
while parse_stmnt_01()
drop nextln_01()
loop
if token <> NEXT_TKN
return parse_err_11(@bad_stmnt)
fin
emit_jump_10(tag_for)
emit_codetag_10(break_tag)
emit_drop()
break_tag = tag_prevbrk
stack_loop = stack_loop - 1
is WHILE_TKN
tag_while = ctag_new_01()
tag_wend = ctag_new_01()
tag_prevbrk = break_tag
break_tag = tag_wend
emit_codetag_10(tag_while)
drop parse_expr_01()
emit_brfls_10(tag_wend)
while parse_stmnt_01()
drop nextln_01()
loop
if token <> LOOP_TKN
return parse_err_11(@no_loop)
fin
emit_jump_10(tag_while)
emit_codetag_10(tag_wend)
break_tag = tag_prevbrk
is REPEAT_TKN
tag_repeat = ctag_new_01()
tag_prevbrk = break_tag
break_tag = ctag_new_01()
emit_codetag_10(tag_repeat)
drop scan_01()
while parse_stmnt_01()
drop nextln_01()
loop
if token <> UNTIL_TKN
return parse_err_11(@no_until)
fin
drop parse_expr_01()
emit_brfls_10(tag_repeat)
emit_codetag_10(break_tag)
break_tag = tag_prevbrk
is CASE_TKN
stack_loop = stack_loop + 1
tag_choice = ctag_new_01()
tag_prevbrk = break_tag
break_tag = ctag_new_01()
drop parse_expr_01()
drop nextln_01()
while token <> ENDCASE_TKN
when token
is OF_TKN
if !parse_expr_01()
return parse_err_11(@bad_stmnt)
fin
emit_brne_10(tag_choice)
while parse_stmnt_01()
drop nextln_01()
loop
emit_jump_10(break_tag)
emit_codetag_10(tag_choice)
tag_choice = ctag_new_01()
is DEFAULT_TKN
drop scan_01()
while parse_stmnt_01()
drop nextln_01()
loop
if token <> ENDCASE_TKN
return parse_err_11(@bad_stmnt)
fin
otherwise
return parse_err_11(@bad_stmnt)
wend
loop
emit_codetag_10(break_tag)
emit_drop()
break_tag = tag_prevbrk
stack_loop = stack_loop - 1
is BREAK_TKN
if break_tag
emit_jump_10(break_tag)
else
return parse_err_11(@bad_stmnt)
fin
is RETURN_TKN
if infunc
for i = 1 to stack_loop
emit_drop()
next
drop parse_expr_01()
emit_leave_10(framesize)
else
return parse_err_11(@bad_stmnt)
fin
is EXIT_TKN
drop parse_expr_01()
emit_exit()
is DROP_TKN
drop parse_expr_01()
emit_drop()
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 NFUNC_TKN
return FALSE
is EOF_TKN
return FALSE
is EOL_TKN
return TRUE
otherwise
if token == ID_TKN
saveptr = tknptr
idptr = id_lookup_21(tknptr, tknlen)
if !idptr
return FALSE
fin
type = (idptr).idtype
if type & ADDR_TYPE
addr = (idptr):idval
if scan_01() == SET_TKN
if type & VAR_TYPE
drop parse_expr_01()
if type & LOCAL_TYPE
if type & BYTE_TYPE
emit_slb_10(addr)
else
emit_slw_10(addr)
fin
else
if type & BYTE_TYPE
emit_sab_10(addr)
else
emit_saw_10(addr)
fin
fin
return TRUE
fin
elsif token == SETLIST_TKN and type & VAR_TYPE
return parse_setlist_21(addr, type);
elsif token == EOL_TKN and type & FUNC_TYPE
emit_call_10(addr)
return TRUE
fin
fin
tknptr = saveptr
fin
rewind_10(tknptr)
type = parse_value_11(0)
if type
if token == SET_TKN
drop parse_expr_01()
if type & XBYTE_TYPE
emit_sb()
else
emit_sw()
fin
elsif token == SETLIST_TKN
return parse_setlist_21(0, type);
else
if type & BPTR_TYPE
emit_lb()
elsif type & WPTR_TYPE
emit_lw()
fin
fin
else
return parse_err_11(@bad_syntax)
fin
wend
if scan_01() <> EOL_TKN
return parse_err_11(@bad_syntax)
fin
return TRUE
end
def parse_var_11(type)
byte consttype, constsize, idlen
word idptr, constval, arraysize, size
idlen = 0
size = 1
if scan_01() == ID_TKN
idptr = tknptr
idlen = tknlen
if scan_01() == OPEN_BRACKET_TKN
size = 0
drop parse_constexpr_21(@size, @constsize)
if token <> CLOSE_BRACKET_TKN
return parse_err_11(@no_close_bracket)
fin
drop scan_01()
fin
fin
if type == WORD_TYPE
size = size * 2
fin
if token == SET_TKN
if infunc
return parse_err_11(@no_local_init)
fin
if idlen
drop iddata_add_41(idptr, idlen, type, 0)
fin
consttype = parse_constexpr_21(@constval, @constsize)
if consttype
arraysize = emit_data_41(type, consttype, constval, constsize)
while token == COMMA_TKN
consttype = parse_constexpr_21(@constval, @constsize)
if consttype
arraysize = arraysize + emit_data_41(type, consttype, constval, constsize)
else
return parse_err_11(@bad_decl)
fin
loop
if token <> EOL_TKN
return parse_err_11(@no_close_bracket)
fin
iddata_size_30(PTR_TYPE, size, arraysize);
else
return parse_err_11(@bad_decl)
fin
elsif idlen
if infunc
drop idlocal_add_41(idptr, idlen, type, size)
else
drop iddata_add_41(idptr, idlen, type, size)
fin
fin
return TRUE
end
def parse_vars_01
byte idlen, type, size
word value, idptr
when token
is CONST_TKN
if scan_01() <> ID_TKN
return parse_err_11(@bad_cnst)
fin
idptr = tknptr;
idlen = tknlen
if scan_01() <> SET_TKN
return parse_err_11(@bad_cnst)
fin
if !parse_constexpr_21(@value, @size)
return parse_err_11(@bad_cnst)
fin
drop idconst_add_31(idptr, idlen, value)
is BYTE_TKN
type = BYTE_TYPE
repeat
if !parse_var_11(type)
return FALSE
fin
until token <> COMMA_TKN
is WORD_TKN
type = WORD_TYPE
repeat
if !parse_var_11(type)
return FALSE
fin
until token <> COMMA_TKN
is FUNC_TKN
repeat
if scan_01() == ID_TKN
drop idfunc_add_31(tknptr, tknlen, ctag_new_01())
else
return parse_err_11(@bad_decl)
fin
until scan_01() <> COMMA_TKN
is EOL_TKN
return TRUE
otherwise
return FALSE
wend
return TRUE
end
def parse_func_01
byte opt, cfnparms
word func_tag, idptr
if token == IFUNC_TKN or token == NFUNC_TKN
opt = token - IFUNC_TKN
if scan_01() <> ID_TKN
return parse_err_11(@bad_decl)
fin
cfnparms = 0
infunc = TRUE
idptr = idglobal_lookup_21(tknptr, tknlen)
if idptr
func_tag = (idptr):idval
else
func_tag = ctag_new_01()
drop idfunc_add_31(tknptr, tknlen, func_tag)
fin
emit_codetag_10(func_tag)
retfunc_tag = ctag_new_01()
idlocal_init()
if scan_01() == OPEN_PAREN_TKN
repeat
if scan_01() == ID_TKN
cfnparms = cfnparms + 1
drop idlocal_add_41(tknptr, tknlen, WORD_TYPE, 2)
drop scan_01()
fin
until token <> COMMA_TKN
if token <> CLOSE_PAREN_TKN
return parse_err_11(@bad_decl)
fin
drop scan_01()
fin
while parse_vars_01()
drop nextln_01()
loop
emit_enter_20(framesize, cfnparms)
prevstmnt = 0
while parse_stmnt_01()
drop nextln_01()
loop
infunc = FALSE
if token <> END_TKN
return parse_err_11(@bad_syntax)
fin
if scan_01() <> EOL_TKN
return parse_err_11(@bad_syntax)
fin
if prevstmnt <> RETURN_TKN
emit_leave_10(framesize)
fin
return TRUE
elsif token == EOL_TKN
return TRUE
fin
return FALSE
end
def parse_module_01
entrypoint = 0
idglobal_init()
idlocal_init()
if nextln_01()
while parse_vars_01()
drop nextln_01()
loop
while parse_func_01()
drop nextln_01()
loop
if token <> DONE_TKN
emit_start()
prevstmnt = 0
while parse_stmnt_01()
drop nextln_01()
loop
if token <> DONE_TKN
drop parse_err_11(@no_done)
fin
if prevstmnt <> EXIT_TKN
emit_const_10(0)
emit_exit()
fin
fin
; dumpsym(idglobal_tbl, globals)
; prstr(@entrypt_str)
; prword(entrypoint)
; crout()
; keyin_01()
return TRUE
fin
return FALSE
end
;
; Init editor
;
if !(^machid & $80)
flags = uppercase ? shiftlock
keyin_01 = @keyin2_01
else
keyin_01 = @keyin2e_01
fin
inittxtbuf()
if ^argbuff
strcpy_20(argbuff, @txtfile)
prstr(@txtfile)
readtxt_10(@txtfile)
else
numlines = 1
fin
curschr = '+'
flags = flags ? insmode
drawscrn_20(scrntop, scrnleft)
curson()
editmode()
done
Reference in New Issue View Git Blame Copy Permalink