6502/PLASMA
1
0
Fork 0
mirror of https://github.com/dschmenk/PLASMA.git synced 2024-06-01 19:41:36 +00:00
Code Issues Projects Releases Wiki Activity
5fe534f6b1
PLASMA/src/toolsrc/sb.pla
David Schmenk 5fe534f6b1 Text formatting clean-up
2017-12-17 13:55:29 -08:00

4135 lines
102 KiB
Plaintext
Raw 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 keyctrlf = $86
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 keyctrly = $99
const keyctrlz = $9A
const keydelete = $FF
const getbuff = $01FF
//
// 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 = $80 // = memory@16 bytes per bit map, 128 bytes per 8 bit map, 1K bytes per 8 byte map
const maxlnlen = 79
const strheap = $6900
const strheasz = $4000
const codebuff = $A900
const codebuffsz = $1000
const pgjmp = 16
const changed = 1
const insmode = 2
const showcurs = 4
const uppercase = 8
const shiftlock = 128
//
// Argument buffer (must be first declared variables)
//
word signature = $EEEE // buffer signature
byte = 32 // buffer length
byte[32] argbuff = "" // buffer
//
// Text screen row address array
//
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
//
// Editor variables
//
byte nullstr = ""
byte version = "PLASMA ][ SANDBOX VERSION 00.96"
byte errorstr = "ERROR: $"
byte okstr = "OK"
byte outofmem = "OUT OF MEMORY!"
byte losechng = "LOSE CHANGES TO FILE (Y/N)?"
byte untitled = "UNTITLED.PLA"
byte[64] txtfile = "UNTITLED.PLA"
byte flags = 0
byte flash = 0
word numlines = 0
word cutbuf = 0
byte perr, cursx, cursy, scrnleft, curscol, underchr, curschr
word keyin, cursrow, scrntop, cursptr
//
// Predeclared functions
//
predef cmdmode(clrscrn)#0
//
// 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 = $FC // |
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 ALT_COMP_TKN = $FE // ~
const LOGIC_NOT_TKN = $A1 // !
const BPTR_TKN = $DE // ^
const WPTR_TKN = $AA // *
const PTRB_TKN = $D8 // X
const PTRW_TKN = $D7 // W
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 DEF_TKN = $95
const STRUC_TKN = $96
const DONE_TKN = $98
const RETURN_TKN = $99
const BREAK_TKN = $9A
const CONT_TKN = $9B
const EXIT_TKN = $9C
const EVAL_TKN = $9D
const PREDEF_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 CONSTADDR_TYPE = $61 // (CONST_TYPE | PTR_TYPE)
const STR_TYPE = $80
//
// Keywords
//
byte keywrds = "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", DEF_TKN
byte = "END", END_TKN
byte = "AND", LOGIC_AND_TKN
byte = "NOT", LOGIC_NOT_TKN
byte = "BYTE", BYTE_TKN
byte = "WORD", WORD_TKN
byte = "ELSE", ELSE_TKN
byte = "NEXT", NEXT_TKN
byte = "WHEN", CASE_TKN
byte = "LOOP", LOOP_TKN
byte = "STEP", STEP_TKN
byte = "DONE", DONE_TKN
byte = "WEND", ENDCASE_TKN
byte = "CONST", CONST_TKN
byte = "STRUC", STRUC_TKN
byte = "ELSIF", ELSEIF_TKN
byte = "WHILE", WHILE_TKN
byte = "UNTIL", UNTIL_TKN
byte = "BREAK", BREAK_TKN
byte = "DOWNTO", DOWNTO_TKN
byte = "REPEAT", REPEAT_TKN
byte = "RETURN", RETURN_TKN
byte = "PREDEF", PREDEF_TKN
byte = "CONTINUE", CONT_TKN
byte = "OTHERWISE",DEFAULT_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[16] opstack
byte[16] precstack
word opsp = -1
word[16] valstack
byte[16] sizestack
byte[16] typestack
word valsp = -1
//
// Symbol table variables
//
const idglobal_tblsz = 2048
const idlocal_tblsz = 512
const idglobal_tbl = $1600
const idlocal_tbl = $1E00
const ctag_max = 1024
const ctag_tbl = $800
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 IS_RESOLVED = $8000
const IS_RELATIVE = $8000
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
word scanptr = @nullstr
byte scanchr, token, tknlen
byte parserrpos, parserr = 0
word tknptr, parserrln
word constval
word lineno = 0
//
// Compiler output messages
//
byte bytes_compiled_str[] = "\nBYTES COMPILED: "
byte dup_id[] = "DUPLICATE IDENTIFIER"
byte undecl_id[] = "UNDECLARED IDENTIFIER"
byte bad_cnst[] = "BAD CONSTANT"
byte bad_struc[] = "BAD STRUCTURE"
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_ctag_offst[] = "CODE OFFSET NOT SUPPORTED"
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[] = "call"
byte RUNTIME0[] = "CALL"
byte runtime1[] = "syscall"
byte RUNTIME1[] = "SYSCALL"
byte runtime2[] = "memset"
byte RUNTIME2[] = "MEMSET"
byte runtime3[] = "memcpy"
byte RUNTIME3[] = "MEMCPY"
byte runtime4[] = "putc"
byte RUNTIME4[] = "PUTC"
byte runtime5[] = "getc"
byte RUNTIME5[] = "GETC"
byte runtime6[] = "puts"
byte RUNTIME6[] = "PUTS"
byte runtime7[] = "gets"
byte RUNTIME7[] = "GETS"
byte runtime8[] = "puti"
byte RUNTIME8[] = "PUTI"
byte runtime9[] = "home"
byte RUNTIME9[] = "HOME"
byte runtime10[] = "gotoxy"
byte RUNTIME10[] = "GOTOXY"
//
// Parser variables
//
byte infunc = 0
byte stack_loop = 0
byte prevstmnt = 0
word retfunc_tag = 0
word break_tag = 0
word cont_tag = 0
predef parse_constexpr(str,val), parse_expr, parse_module
//
// ASM utility functions
//
// Defines for ASM routines
//
asm equates
INTERP = $03D0
LCRDEN = $C080
LCWTEN = $C081
ROMEN = $C082
LCRWEN = $C083
LCBNK2 = $00
LCBNK1 = $08
!SOURCE "vmsrc/plvmzp.inc"
end
//
// SAVE VM STATE
//
asm save_vmstate
LDA $03F2
STA VMRESET
LDA $03F3
STA VMRESET+1
LDA $03F4
STA VMRESET+2
LDA #<RESETENTRY
STA $03F2
LDA #>RESETENTRY
STA $03F3
EOR #$A5
STA $03F4
DEX
RTS
end
//
// RESTORE VM STATE
//
asm restore_vmstate
RESETENTRY
LDA VMRESET
STA $03F2
LDA VMRESET+1
STA $03F3
LDA VMRESET+2
STA $03F4
LDX #$00
STX IFPL
LDA #$BF
STA IFPH
LDX #$FE
TXS
LDX #ESTKSZ/2
BIT ROMEN
JMP $2000
VMRESET !FILL 3
end
//
// CALL 6502 ROUTINE
// CALL(ADDR, AREG, XREG, YREG, STATUS)
//
asm call(addr, areg, xreg, yreg, status)
REGVALS = SRC
PHP
LDA ESTKL+4,X
STA TMPL
LDA ESTKH+4,X
STA TMPH
LDA ESTKL,X
PHA
LDA ESTKL+1,X
TAY
LDA ESTKL+3,X
PHA
LDA ESTKL+2,X
INX
INX
INX
INX
STX ESP
TAX
PLA
BIT ROMEN
PLP
JSR JMPTMP
PHP
BIT LCRDEN+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
JMPTMP JMP (TMP)
end
//
// CALL PRODOS
// SYSCALL(CMD, PARAMS)
//
asm syscall(cmd, params)
LDA ESTKL,X
LDY ESTKH,X
STA PARAMS
STY PARAMS+1
INX
LDA ESTKL,X
STA CMD
JSR $BF00
CMD: !BYTE 00
PARAMS: !WORD 0000
LDY #$00
STA ESTKL,X
STY ESTKH,X
RTS
end
// SET MEMORY TO VALUE
// MEMSET(ADDR, VALUE, SIZE)
// With optimizations from Peter Ferrie
//
asm memset(addr, val, size)
LDA ESTKL+2,X
STA DSTL
LDA ESTKH+2,X
STA DSTH
LDY ESTKL,X
BEQ +
INC ESTKH,X
LDY #$00
+ LDA ESTKH,X
BEQ SETMEX
SETMLPL CLC
LDA ESTKL+1,X
SETMLPH STA (DST),Y
DEC ESTKL,X
BNE +
DEC ESTKH,X
BEQ SETMEX
+ INY
BNE +
INC DSTH
+ BCS SETMLPL
SEC
LDA ESTKH+1,X
BCS SETMLPH
SETMEX INX
INX
RTS
end
//
// COPY MEMORY
// MEMCPY(DSTADDR, SRCADDR, SIZE)
//
asm memcpy(dst, src, size)
INX
INX
LDA ESTKL-2,X
ORA ESTKH-2,X
BEQ CPYMEX
LDA ESTKL-1,X
CMP ESTKL,X
LDA ESTKH-1,X
SBC ESTKH,X
BCC REVCPY
;
; FORWARD COPY
;
LDA ESTKL,X
STA DSTL
LDA ESTKH,X
STA DSTH
LDA ESTKL-1,X
STA SRCL
LDA ESTKH-1,X
STA SRCH
LDY ESTKL-2,X
BEQ FORCPYLP
INC ESTKH-2,X
LDY #$00
FORCPYLP LDA (SRC),Y
STA (DST),Y
INY
BNE +
INC DSTH
INC SRCH
+ DEC ESTKL-2,X
BNE FORCPYLP
DEC ESTKH-2,X
BNE FORCPYLP
RTS
;
; REVERSE COPY
;
REVCPY ;CLC
LDA ESTKL-2,X
ADC ESTKL,X
STA DSTL
LDA ESTKH-2,X
ADC ESTKH,X
STA DSTH
CLC
LDA ESTKL-2,X
ADC ESTKL-1,X
STA SRCL
LDA ESTKH-2,X
ADC ESTKH-1,X
STA SRCH
DEC DSTH
DEC SRCH
LDY #$FF
LDA ESTKL-2,X
BEQ REVCPYLP
INC ESTKH-2,X
REVCPYLP LDA (SRC),Y
STA (DST),Y
DEY
CPY #$FF
BNE +
DEC DSTH
DEC SRCH
+ DEC ESTKL-2,X
BNE REVCPYLP
DEC ESTKH-2,X
BNE REVCPYLP
CPYMEX RTS
end
//
// CHAR OUT
// COUT(CHAR)
//
asm cout(char)
LDA ESTKL,X
COUT1 BIT $BF98
BMI +
JSR TOUPR
+ ORA #$80
BIT ROMEN
JSR $FDED
BIT LCRDEN+LCBNK2
RTS
end
//
// CHAR IN
// RDKEY()
//
asm cin()
BIT ROMEN
JSR $FD0C
BIT LCRDEN+LCBNK2
DEX
LDY #$00
AND #$7F
STA ESTKL,X
STY ESTKH,X
RTS
end
//
// PRINT STRING
// PRSTR(STR)
//
asm prstr(pstr)
LDY #$00
LDA ESTKL,X
STA SRCL
LDA ESTKH,X
STA SRCH
LDA (SRC),Y
STA TMP
BEQ ++
- INY
LDA (SRC),Y
JSR COUT1
CPY TMP
BNE -
++ RTS
end
//
// READ STRING
// STR = RDSTR(PROMPTCHAR)
//
asm rdstr(prompt)
LDA ESTKL,X
STA $33
STX ESP
BIT ROMEN
JSR $FD6A
BIT LCRDEN+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
RTS
end
//
// EXIT
//
asm exit#0
JSR $BF00
!BYTE $65
!WORD EXITTBL
EXITTBL:
!BYTE 4
!BYTE 0
end
//def toupper_11(c)
// if c >= 'a'
// if c <= 'z'
// return c - $20
// fin
// fin
// return c
//end
asm toupper(char)
LDA ESTKL,X
TOUPR AND #$7F
CMP #'z'+1
BCS +
CMP #'a'
BCC +
SBC #$20
+ STA ESTKL,X
RTS
end
asm clrhibit(strptr)#0
LDA ESTKL,X
STA SRCL
LDA ESTKH,X
STA SRCH
INX
LDY #$00
LDA (SRC),Y
BEQ +
TAY
CLHILP LDA (SRC),Y
AND #$7F
STA (SRC),Y
DEY
BNE CLHILP
+ RTS
end
asm sethibit(strptr)#0
LDA ESTKL,X
STA SRCL
LDA ESTKH,X
STA SRCH
INX
LDY #$00
LDA (SRC),Y
BEQ +
TAY
STHILP LDA (SRC),Y
ORA #$80
STA (SRC),Y
DEY
BNE STHILP
+ RTS
end
asm cpyln(srcstr, dststr)#0
LDA ESTKL,X
STA DSTL
LDA ESTKH,X
STA DSTH
INX
LDA ESTKL,X
STA SRCL
LDA ESTKH,X
STA SRCH
INX
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
RTS
end
//
//def skipspace(scanptr)
// while ^scanptr == ' '
// scanptr = scanptr + 1
// loop
// return scanptr
//end
asm skipspace(scanptr)
LDA #$00
STA SRCL
LDA ESTKH,X
STA SRCH
LDY ESTKL,X
- LDA (SRC),Y
CMP #' '
BNE +
INY
BNE -
INC SRCH
BNE -
+ STY ESTKL,X
LDA SRCH
STA ESTKH,X
RTS
end
//def 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(char)
LDY #$00
LDA ESTKL,X
CMP #'_'
BEQ ISALTRU
CMP #'A'
BCC ISALRET
CMP #'Z'+1
BCC ISALTRU
CMP #'a'
BCC ISALRET
CMP #'z'+1
BCS ISALRET
ISALTRU DEY
ISALRET STY ESTKL,X
STY ESTKH,X
RTS
end
//def isnum(c)
// if c >= '0' and c <= '9'
// return TRUE
// fin
// return FALSE
//end
asm isnum(char)
LDY #$00
LDA ESTKL,X
CMP #'0'
BCC +
CMP #'9'+1
BCS +
DEY
+ STY ESTKL,X
STY ESTKH,X
RTS
end
//def 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(char)
LDY #$00
LDA ESTKL,X
CMP #'_'
BEQ ISANTRU
CMP #'0'
BCC ISANRET
CMP #'9'+1
BCC ISANTRU
CMP #'A'
BCC ISANRET
CMP #'Z'+1
BCC ISANTRU
CMP #'a'
BCC ISANRET
CMP #'z'+1
BCS ISANRET
ISANTRU DEY
ISANRET STY ESTKL,X
STY ESTKH,X
RTS
end
//
// Runtime routines
//
def home
return call($FC58, 0, 0, 0, 0)
end
def gotoxy(x, y)
^$24 = x + ^$20
return call($FB5B, y + ^$22, 0, 0, 0)
end
//
// 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
params.5 = 0
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[3]
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#0
cout($0D)
end
def bell#0
call($FBDD, 0, 0, 0, 0)
end
//
// Memory management routines
//
def strcpy(dststr, srcstr)#0
byte strlen
strlen = ^srcstr
while ^(srcstr + strlen) == $8D or ^(srcstr + strlen) == $A0
strlen = strlen - 1
loop
^dststr = strlen
memcpy(dststr + 1, srcstr + 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
return 0
end
def 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)
return 0
end
def freestr(strptr)#0
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(newptr, strptr, strlen + 1)
^newptr = strlen
return newptr
fin
return @nullstr
end
def inittxtbuf#0
memset(strheapmap, 0, strheapmsz)
memset(strlinbuf, @nullstr, maxfill * 2)
numlines = 1
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)#0
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)#0
byte i, chr
for i = ^strptr downto 1
chr = ^(strptr + i)
if chr & $E0 == $00
^(strptr + i) = chr + $E0
fin
next
end
def txtupper#0
word i, strptr
flags = flags | uppercase
for i = numlines - 1 downto 0
strupper(strlinbuf:[i])
next
end
def txtlower#0
word i, strptr
flags = flags & ~uppercase
for i = numlines - 1 downto 0
strlower(strlinbuf:[i])
next
end
def prbyte(h)#0
cout('$')
call($FDDA, h, 0, 0, 0)
end
def prword(h)#0
cout('$')
call($F941, h >> 8, h, 0, 0)
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--
loop
numstr[place] = i + '0'
place--
if sign
numstr[place] = '-'
place--
fin
numstr[place] = 6 - place
return prstr(@numstr[place])
end
def nametostr(namestr, len, strptr)#0
^strptr = len
memcpy(strptr + 1, namestr, len)
end
//
// File routines
//
def readtxt(filename)#0
byte txtbuf[81], refnum, i, j
refnum = open(filename, iobuffer)
if refnum and not perr
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
//
// Make sure there is a blank line at the end of the buffer
//
if numlines < maxlines and strlinbuf:[numlines - 1] <> @nullstr
strlinbuf:[numlines] = @nullstr
numlines++
fin
fin
if refnum; close(refnum); fin
end
def writetxt(filename)#0
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
fin
//
// Remove blank lines at end of text.
//
while numlines > 1 and strlinbuf:[numlines - 1] == @nullstr; numlines = numlines - 1; loop
//
// Write all the text line to the file.
//
for i = 0 to numlines - 1
cpyln(strlinbuf:[i], @txtbuf)
txtbuf++
txtbuf[txtbuf] = $0D
write(refnum, @txtbuf + 1, txtbuf)
if !(i & $0F); cout('.'); fin
next
close(refnum)
end
//
// Screen routines
//
def clrscrn#0
call($FC58, 0, 0, 0, 0)
end
def drawrow(row, ofst, strptr)#0
byte numchars
word scrnptr
scrnptr = txtscrn[row]
if ofst >= ^strptr
numchars = 0
else
numchars = ^strptr - ofst
fin
if numchars >= 40
numchars = 40
else
memset(scrnptr + numchars, $A0A0, 40 - numchars)
fin
memcpy(scrnptr, strptr + ofst + 1, numchars)
end
def drawscrn(toprow, ofst)#0
byte row, numchars
word strptr, scrnptr
for row = 0 to 23
strptr = strlinbuf:[toprow + row]
scrnptr = txtscrn[row]
numchars = ofst >= ^strptr ?? 0 :: ^strptr - ofst
if numchars >= 40
numchars = 40
else
memset(scrnptr + numchars, $A0A0, 40 - numchars)
fin
memcpy(scrnptr, strptr + ofst + 1, numchars)
next
end
def cursoff#0
if flags & showcurs
^cursptr = underchr
flags = flags & ~showcurs
fin
end
def curson#0
if !(flags & showcurs)
cursptr = txtscrn[cursy] + cursx
underchr = ^cursptr
^cursptr = curschr
flags = flags | showcurs
fin
end
def cursflash#0
if flags & showcurs
if flash == 0
^cursptr = curschr
elsif flash == 128
^cursptr = underchr
fin
flash++
fin
end
def redraw#0
cursoff
drawscrn(scrntop, scrnleft)
curson
end
def curshome#0
cursoff
cursrow = 0
curscol = 0
cursx = 0
cursy = 0
scrnleft = 0
scrntop = 0
drawscrn(scrntop, scrnleft)
curson
end
def cursend#0
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#0
if cursrow > 0
cursoff
cursrow--
if cursy > 0
cursy--
else
scrntop = cursrow
drawscrn(scrntop, scrnleft)
fin
curson
fin
end
def pgup#0
byte i
for i = pgjmp downto 0
cursup
next
end
def cursdown#0
if cursrow < numlines - 1
cursoff
cursrow++
if cursy < 23
cursy++
else
scrntop = cursrow - 23
drawscrn(scrntop, scrnleft)
fin
curson
fin
end
def pgdown#0
byte i
for i = pgjmp downto 0
cursdown
next
end
def cursleft#0
if curscol > 0
cursoff
curscol--
if cursx > 0
cursx--
else
scrnleft = curscol
drawscrn(scrntop, scrnleft)
fin
curson
fin
end
def pgleft#0
byte i
for i = 7 downto 0
cursleft
next
end
def cursright#0
if curscol < 80
cursoff
curscol++
if cursx < 39
cursx++
else
scrnleft = curscol - 39
drawscrn(scrntop, scrnleft)
fin
curson
fin
end
def pgright#0
byte i
for i = 7 downto 0
cursright
next
end
//
// Keyboard routines
//
def keyin2e
byte key
repeat
cursflash
key = ^keyboard
until key >= 128
^keystrobe
if ^$C062 & 128 // Closed Apple pressed
when key
is keyarrowleft
key = keyctrla; break
is keyarrowright
key = keyctrls; break
is keyarrowup
key = keyctrlw; break
is keyarrowdown
key = keyctrlz; break
is keyenter
key = keyctrlf; break
wend
fin
return key
end
def keyin2
byte key
repeat
cursflash
key = ^keyboard
if key == keyctrll
^keystrobe
flags = flags ^ shiftlock
key = 0
fin
until key >= 128
^keystrobe
when key
is keyctrln
key = $DB; break // [
is keyctrlp
key = $DF; break // _
is keyctrlb
key = $FC; break // |
is keyctrly
key = $FE; break // ~
// is keyarrowleft
// if ^pushbttn3 < 128
// key = $FF
// fin
// break
otherwise
if key >= $C0 and flags < shiftlock
if ^pushbttn3 < 128
when key
is $C0
key = $D0; break // P
is $DD
key = $CD; break // M
is $DE
key = $CE; break // N
wend
else
key = key | $E0
fin
fin
wend
return key
end
//
// Printer routines
//
def printtxt(slot)#0
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 + 1], @strlinbuf:[row], (numlines - row) * 2)
strlinbuf:[row] = @nullstr
numlines++
flags = flags | changed
return 1
fin
bell
return 0
end
def cutline#0
freestr(cutbuf)
cutbuf = strlinbuf:[cursrow]
memcpy(@strlinbuf:[cursrow], @strlinbuf:[cursrow + 1], (numlines - cursrow) * 2)
if numlines > 1
numlines--
fin
flags = flags | changed
if cursrow == numlines
cursup
fin
redraw
end
def pasteline#0
if cutbuf and numlines < maxlines
memcpy(@strlinbuf:[cursrow + 1], @strlinbuf:[cursrow], (numlines - cursrow) * 2)
strlinbuf:[cursrow] = newstr(cutbuf)
numlines++
flags = flags | changed
redraw
else
bell
fin
end
def joinline#0
byte joinstr[80], joinlen
if cursrow < numlines - 1
strcpy(@joinstr, strlinbuf:[cursrow])
joinlen = joinstr + ^(strlinbuf:[cursrow + 1])
if joinlen < 80
memcpy(@joinstr + joinstr + 1, strlinbuf:[cursrow + 1] + 1, ^(strlinbuf:[cursrow + 1]))
joinstr = joinlen
freestr(strlinbuf:[cursrow])
strlinbuf:[cursrow] = newstr(@joinstr)
freestr(strlinbuf:[cursrow + 1])
numlines--
memcpy(@strlinbuf:[cursrow + 1], @strlinbuf:[cursrow + 2], (numlines - cursrow) * 2)
flags = flags | changed
redraw
else
bell
fin
fin
end
def splitline#0
byte splitstr[80], splitlen
if openline(cursrow + 1)
if curscol
splitlen = ^(strlinbuf:[cursrow])
if curscol < splitlen - 1
memcpy(@splitstr + 1, strlinbuf:[cursrow] + curscol + 1, splitlen - curscol)
splitstr = splitlen - curscol
strlinbuf:[cursrow + 1] = newstr(@splitstr)
memcpy(@splitstr + 1, strlinbuf:[cursrow] + 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 TRUE
elsif key == keydelete
return TRUE
elsif key == keyctrld
return TRUE
elsif key == keyctrlr
return TRUE
fin
return FALSE
end
def editline(key)
byte editstr[80]
word undoline
if (editkey(key))
flags = flags | changed
memset(@editstr, $A0A0, 80)
strcpy(@editstr, strlinbuf:[cursrow])
undoline = strlinbuf:[cursrow]
strlinbuf:[cursrow] = @editstr
repeat
if key >= keyspace
if key == keydelete
if curscol > 0
if curscol <= editstr
memcpy(@editstr[curscol], @editstr[curscol + 1], editstr - curscol)
editstr--
fin
curscol--
cursoff
if cursx > 0
cursx--
drawrow(cursy, scrnleft, @editstr)
else
scrnleft--
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 + 1], @editstr[curscol], editstr - curscol)
fin
else
curscol--
cursx--
key = editstr[curscol]
bell
fin
elsif curscol > editstr
editstr = curscol
fin
editstr[curscol] = caseconv(key)
cursoff
if cursx <= 39
drawrow(cursy, scrnleft, @editstr)
else
scrnleft++
cursx = 39
drawscrn(scrntop, scrnleft)
fin
curson
else
bell
fin
elsif key == keyctrld
if curscol < editstr
strcpy(undoline, @editstr)
memcpy(@editstr[curscol + 1], @editstr[curscol + 2], editstr - curscol)
editstr--
cursoff
drawrow(cursy, scrnleft, @editstr)
curson
fin
elsif key == keyctrlr
strcpy(@editstr, undoline)
cursoff
drawrow(cursy, scrnleft, @editstr)
curson
fin
key = keyin()
until not editkey(key)
if editstr
strlinbuf:[cursrow] = newstr(@editstr)
else
strlinbuf:[cursrow] = @nullstr
fin
freestr(undoline)
fin
return key
end
def editmode#0
repeat
when editline(keyin())
is keyarrowup
cursup; break
is keyarrowdown
cursdown; break
is keyarrowleft
cursleft; break
is keyarrowright
cursright; break
is keyctrlw
pgup; break
is keyctrlz
pgdown; break
is keyctrla
pgleft; break
is keyctrls
pgright; break
is keyctrlq
curshome; break
is keyctrle
cursend; break
is keyctrlx
cutline; break
is keyctrlv
pasteline; break
is keyctrlf
if numlines < maxlines and cursrow == numlines - 1
strlinbuf:[numlines] = @nullstr
numlines++
fin
cursdown
is keyctrlo
openline(cursrow)
curscol = 0
cursx = 0
scrnleft = 0
redraw
break
is keyenter
if flags & insmode
splitline
else
cursdown
curscol = 0
cursx = 0
scrnleft = 0
redraw
fin
break
is keyctrlt
joinline; break
is keyctrli
if flags & insmode
flags = flags & ~insmode
curschr = ' '
else
flags = flags | insmode
curschr = '+'
fin
break
is keyctrlc
if flags & uppercase
txtlower
else
txtupper
fin
redraw
break
is keyescape
cursoff
cmdmode(TRUE)
redraw
break
wend
until FALSE
end
//
// Command mode
//
def prfiles(optpath)#0
byte path[64]
byte refnum
byte firstblk
byte entrylen, entriesblk
byte i, type, len
word entry, filecnt
if ^optpath
strcpy(@path, optpath)
else
getpfx(@path)
prstr(@path)
crout
fin
refnum = open(@path, iobuffer)
if !refnum
return
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
end
def striplead(strptr, chr)#0
while ^strptr and ^(strptr + 1) == chr
memcpy(strptr + 1, strptr + 2, ^strptr)
^strptr--
loop
end
def parsecmd(strptr)
byte cmd
cmd = 0
striplead(strptr, ' ')
if ^strptr
cmd = ^(strptr + 1)
memcpy(strptr + 1, strptr + 2, ^strptr)
^strptr--
fin
if ^strptr
striplead(strptr, ' ')
fin
return cmd
end
def chkchng
if flags & changed
prstr(@losechng)
if toupper(keyin()) == 'N'
crout
return FALSE
fin
crout
fin
return TRUE
end
def quit#0
if chkchng
exit
fin
end
def cmdmode(clearscr)#0
byte slot
word cmdptr
if (clearscr)
clrscrn
prstr(@version)
fin
crout
while TRUE
prstr(@txtfile)
cmdptr = rdstr($BA)
when toupper(parsecmd(cmdptr))
is 'A'
readtxt(cmdptr)
flags = flags | changed
break
is 'R'
if chkchng
inittxtbuf
numlines = 0
entrypoint = 0
strcpy(@txtfile, cmdptr)
readtxt(@txtfile)
if numlines == 0; numlines = 1; fin
flags = flags & ~changed
fin
break
is 'W'
if ^cmdptr
strcpy(@txtfile, cmdptr)
fin
writetxt(@txtfile)
if flags & changed; entrypoint = 0; fin
flags = flags & ~changed
break
is 'C'
prfiles(cmdptr); break
is 'P'
setpfx(cmdptr); break
is 'H'
if ^cmdptr
slot = cmdptr.1 - '0'
else
slot = 1
fin
printtxt(slot)
break
is 'Q'
quit
is 'E'
is 0
return
is 'N'
if chkchng
inittxtbuf
strcpy(@txtfile, @untitled)
entrypoint = 0
fin
break
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
entrypoint = 0
else
crout
fin
fin
if entrypoint
save_vmstate
entrypoint()
restore_vmstate
fin
crout
break
otherwise
bell
cout('?')
crout
wend
if perr
prstr(@errorstr)
call($FDDA, perr, 0, 0, 0)
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
//
// Code tags. Upper bit is IS_RESOLVED flag, lower 15 is offset into codebuff
// Flags are:
//
def ctag_new
if codetag >= ctag_max; return parse_err(@ctag_full); fin
codetag = codetag + 1
ctag_tbl:[codetag] = 0 // Unresolved, nothing to update yet
return codetag | IS_CTAG
end
def ctag_resolve(ctag)#0
word updtptr, nextptr
ctag = ctag & MASK_CTAG // Better be a ctag!
if ctag_tbl:[ctag] & IS_RESOLVED;parse_err(@dup_id); return; fin
updtptr = ctag_tbl:[ctag] & MASK_CTAG
while updtptr
//
// Update list of addresses needing resolution
//
updtptr = updtptr + codebuff
nextptr = *updtptr & MASK_CTAG
if *updtptr & IS_RELATIVE
*updtptr = codeptr - updtptr
else
*updtptr = codeptr
fin
updtptr = nextptr
loop
ctag_tbl:[ctag] = (codeptr - codebuff) | IS_RESOLVED
end
//
// Emit data/bytecode
//
def emit_byte(bval)#0
^codeptr = bval
codeptr++
end
def emit_word(wval)#0
*codeptr = wval
codeptr = codeptr + 2
end
def emit_fill(size)#0
memset(codeptr, 0, size)
codeptr = codeptr + size
end
def emit_op(op)#0
lastop = op
emit_byte(op)
end
def emit_addr(tag)#0
word updtptr
if tag & IS_CTAG
tag = tag & MASK_CTAG
if ctag_tbl:[tag] & IS_RESOLVED
updtptr = (ctag_tbl:[tag] & MASK_CTAG) + codebuff
else
//
// Add to list of tags needing resolution
//
updtptr = ctag_tbl:[tag] & MASK_CTAG
ctag_tbl:[tag] = codeptr - codebuff
fin
emit_word(updtptr)
else
emit_word(tag + codebuff)
fin
end
def emit_reladdr(tag)#0
word updtptr
if tag & IS_CTAG
tag = tag & MASK_CTAG
if ctag_tbl:[tag] & IS_RESOLVED
updtptr = ((ctag_tbl:[tag] & MASK_CTAG) + codebuff) - codeptr
else
//
// Add to list of tags needing resolution
//
updtptr = ctag_tbl:[tag] | IS_RELATIVE
ctag_tbl:[tag] = codeptr - codebuff
fin
emit_word(updtptr)
else
emit_word(tag - (codeptr - codebuff))
fin
end
def emit_iddata(value, size, namestr)#0
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--
emit_byte(constsize)
while constsize > 0
emit_byte(^chrptr)
chrptr++
constsize--
loop
else
if vartype & BYTE_TYPE
size = 1
emit_byte(constval)
else
size = 2
if consttype == CONSTADDR_TYPE
emit_addr(constval)
else
emit_word(constval)
fin
fin
fin
return size
end
def emit_const(cval)#0
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_constr(str, size)#0
emit_op($2E)
emit_data(0, STR_TYPE, str, size)
end
def emit_lb#0
emit_op($60)
end
def emit_lw#0
emit_op($62)
end
def emit_llb(offset)#0
emit_op($64)
emit_byte(offset)
end
def emit_llw(offset)#0
emit_op($66)
emit_byte(offset)
end
def emit_lab(tag, offset)#0
if tag & IS_CTAG and offset
parse_err(@no_ctag_offst)
else
emit_op($68)
emit_addr(tag+offset)
fin
end
def emit_law(tag, offset)#0
if tag & IS_CTAG and offset
parse_err(@no_ctag_offst)
else
emit_op($6A)
emit_addr(tag+offset)
fin
end
def emit_sb#0
emit_op($70)
end
def emit_sw#0
emit_op($72)
end
def emit_slb(offset)#0
emit_op($74)
emit_byte(offset)
end
def emit_slw(offset)#0
emit_op($76)
emit_byte(offset)
end
def emit_dup#0
parse_err("No DUP op!")
end
def emit_dlb(offset)#0
emit_op($6C)
emit_byte(offset)
end
def emit_dlw(offset)#0
emit_op($6E)
emit_byte(offset)
end
def emit_sab(tag, offset)#0
if tag & IS_CTAG and offset
parse_err(@no_ctag_offst)
else
emit_op($78)
emit_addr(tag+offset)
fin
end
def emit_saw(tag, offset)#0
if tag & IS_CTAG and offset
parse_err(@no_ctag_offst)
else
emit_op($7A)
emit_addr(tag+offset)
fin
end
def emit_dab(tag, offset)#0
if tag & IS_CTAG and offset
parse_err(@no_ctag_offst)
else
emit_op($7C)
emit_addr(tag+offset)
fin
end
def emit_daw(tag, offset)#0
if tag & IS_CTAG and offset
parse_err(@no_ctag_offst)
else
emit_op($7E)
emit_addr(tag+offset)
fin
end
def emit_call(tag)#0
emit_op($54)
emit_addr(tag)
end
def emit_ical#0
emit_op($56)
end
def emit_push#0
parse_err("Function call too complex")
end
def emit_pull#0
end
def emit_localaddr(offset)#0
emit_op($28)
emit_byte(offset)
end
def emit_globaladdr(tag, offset)#0
if tag & IS_CTAG and offset
parse_err(@no_ctag_offst)
else
emit_op($26)
emit_addr(tag+offset)
fin
end
def emit_indexbyte#0
emit_op($02)
end
def emit_indexword#0
emit_op($1E)
end
def emit_unaryop(op)
when op
is NEG_TKN
emit_op($10); break
is ALT_COMP_TKN
is COMP_TKN
emit_op($12); break
is LOGIC_NOT_TKN
emit_op($20); break
is INC_TKN
emit_op($0C); break
is DEC_TKN
emit_op($0E); break
is BPTR_TKN
emit_op($60); break
is WPTR_TKN
emit_op($62); break
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
break
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
break
is MOD_TKN
emit_op($0A); break
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
break
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
break
is SHL_TKN
emit_op($1A); break
is SHR_TKN
emit_op($1C); break
is AND_TKN
emit_op($14); break
is OR_TKN
emit_op($16); break
is EOR_TKN
emit_op($18); break
is EQ_TKN
emit_op($40); break
is NE_TKN
emit_op($42); break
is GE_TKN
emit_op($48); break
is LT_TKN
emit_op($46); break
is GT_TKN
emit_op($44); break
is LE_TKN
emit_op($4A); break
is LOGIC_OR_TKN
emit_op($22); break
is LOGIC_AND_TKN
emit_op($24); break
otherwise
return FALSE
wend
return TRUE
end
def emit_brtru(tag)#0
emit_op($4E)
emit_reladdr(tag)
end
def emit_brfls(tag)#0
emit_op($4C)
emit_reladdr(tag)
end
def emit_brgt(tag)#0
emit_op($38)
emit_reladdr(tag)
end
def emit_brlt(tag)#0
emit_op($3A)
emit_reladdr(tag)
end
def emit_brne(tag)#0
emit_op($3E)
emit_reladdr(tag)
end
def emit_branch(tag)#0
emit_op($50)
emit_reladdr(tag)
end
def emit_drop#0
emit_op($30)
end
def emit_leave#0
if framesize
emit_op($5A)
else
emit_op($5C)
fin
end
def emit_enter(cparams)#0
emit_byte(emit_enter.[0])
emit_byte(emit_enter.[1])
emit_byte(emit_enter.[2])
if framesize
emit_op($58)
emit_byte(framesize)
emit_byte(cparams)
fin
end
//
// Symbol table
//
def 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--
loop
return 0
end
def dumpsym(idptr, idcnt)#0
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_tbl:[idptr=>idval & MASK_CTAG] & MASK_CTAG) + codebuff)
else
prword(idptr=>idval + codebuff)
fin
else
prword(idptr=>idval)
fin
crout
idptr = idptr + idptr->idname + idrecsz
idcnt--
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++
lastlocal = lastlocal + idrecsz + len
if lastlocal > idlocal_tbl + idlocal_tblsz
prstr(@local_sym_overflw)
exit
fin
framesize = framesize + size
if framesize > 255
return parse_err(@local_overflw)
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++
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)#0
if varsize > initsize
datasize = datasize + varsize
emit_data(0, 0, 0, varsize - initsize)
else
datasize = datasize + initsize
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++
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#0
word ctag
lineno = 0
parserr = 0
codeptr = codebuff
lastop = $FF
entrypoint = 0
globals = 0
lastglobal = idglobal_tbl
codetag = -1
//
// Create local jump table to some library functions
//
ctag = ctag_new
idfunc_add(@runtime0 + 1, runtime0, ctag)
idfunc_add(@RUNTIME0 + 1, RUNTIME0, ctag)
ctag_resolve(ctag)
emit_byte($4C)
emit_word(@call)
ctag = ctag_new
idfunc_add(@runtime1 + 1, runtime1, ctag)
idfunc_add(@RUNTIME1 + 1, RUNTIME1, ctag)
ctag_resolve(ctag)
emit_byte($4C)
emit_word(@syscall)
ctag = ctag_new
idfunc_add(@runtime2 + 1, runtime2, ctag)
idfunc_add(@RUNTIME2 + 1, RUNTIME2, ctag)
ctag_resolve(ctag)
emit_byte($4C)
emit_word(@memset)
ctag = ctag_new
idfunc_add(@runtime3 + 1, runtime3, ctag)
idfunc_add(@RUNTIME3 + 1, RUNTIME3, ctag)
ctag_resolve(ctag)
emit_byte($4C)
emit_word(@memcpy)
ctag = ctag_new
idfunc_add(@runtime4 + 1, runtime4, ctag)
idfunc_add(@RUNTIME4 + 1, RUNTIME4, ctag)
ctag_resolve(ctag)
emit_byte($4C)
emit_word(@cout)
ctag = ctag_new
idfunc_add(@runtime5 + 1, runtime5, ctag)
idfunc_add(@RUNTIME5 + 1, RUNTIME5, ctag)
ctag_resolve(ctag)
emit_byte($4C)
emit_word(@cin)
ctag = ctag_new
idfunc_add(@runtime6 + 1, runtime6, ctag)
idfunc_add(@RUNTIME6 + 1, RUNTIME6, ctag)
ctag_resolve(ctag)
emit_byte($4C)
emit_word(@prstr)
ctag = ctag_new
idfunc_add(@runtime7 + 1, runtime7, ctag)
idfunc_add(@RUNTIME7 + 1, RUNTIME7, ctag)
ctag_resolve(ctag)
emit_byte($4C)
emit_word(@rdstr)
ctag = ctag_new
idfunc_add(@runtime8 + 1, runtime8, ctag)
idfunc_add(@RUNTIME8 + 1, RUNTIME8, ctag)
ctag_resolve(ctag)
emit_byte($4C)
emit_word(@print)
ctag = ctag_new
idfunc_add(@runtime9 + 1, runtime9, ctag)
idfunc_add(@RUNTIME9 + 1, RUNTIME9, ctag)
ctag_resolve(ctag)
emit_byte($4C)
emit_word(@home)
ctag = ctag_new
idfunc_add(@runtime10 + 1, runtime10, ctag)
idfunc_add(@RUNTIME10 + 1, RUNTIME10, ctag)
ctag_resolve(ctag)
emit_byte($4C)
emit_word(@gotoxy)
//
// Start data after jump table
//
datasize = codeptr - codebuff
end
def idlocal_init#0
locals = 0
framesize = 0
lastlocal = idlocal_tbl
end
//
// Alebraic op to stack op
//
def push_op(op, prec)#0
opsp++
if opsp == 16; parse_err(@estk_overflw); return; fin
opstack[opsp] = op
precstack[opsp] = prec
end
def pop_op
if opsp < 0; return parse_err(@estk_underflw); fin
opsp--
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
def push_val(value, size, type)#0
valsp++
if valsp == 16; parse_err(@estk_overflw); return; fin
valstack[valsp] = value
sizestack[valsp] = size
typestack[valsp] = type
end
def pop_val(valptr, sizeptr, typeptr)
if valsp < 0; return parse_err(@estk_underflw); fin
*valptr = valstack[valsp]
^sizeptr = sizestack[valsp]
^typeptr = typestack[valsp]
valsp--
return valsp + 1
end
//
// Lexical anaylzer
//
def keymatch
byte i, keypos
word chrptr
keypos = 0
while keywrds[keypos] < tknlen
keypos = keypos + keywrds[keypos] + 2
loop
chrptr = tknptr - 1
while keywrds[keypos] == tknlen
for i = 1 to tknlen
if toupper(^(chrptr + i)) <> keywrds[keypos + i]
break
fin
next
if i > tknlen
return keywrds[keypos + keywrds[keypos] + 1]
fin
keypos = keypos + keywrds[keypos] + 2
loop
return ID_TKN
end
def scan
//
// Skip whitespace
//
scanptr = skipspace(scanptr)
tknptr = scanptr
scanchr = ^scanptr
//
// Scan for token based on first character
//
if isalpha(scanchr)
//
// ID, either variable name or reserved word
//
repeat
scanptr++
until !isalphanum(^scanptr)
tknlen = scanptr - tknptr
token = keymatch
elsif isnum(scanchr)
//
// Decimal constant
//
token = INT_TKN
constval = 0
repeat
constval = constval * 10 + ^scanptr - '0'
scanptr++
until !isnum(^scanptr)
else
//
// Potential multiple character tokens
//
when scanchr
is '/'
if ^(scanptr + 1) == '/'
token = EOL_TKN
^scanptr = $00
else
token = DIV_TKN
scanptr++
fin
break
is '='
if ^(scanptr + 1) == '='
token = EQ_TKN
scanptr = scanptr + 2
elsif ^(scanptr + 1) == '>'
token = PTRW_TKN
scanptr = scanptr + 2
else
token = SET_TKN
scanptr++
fin
break
is '-'
if ^(scanptr + 1) == '>'
token = PTRB_TKN
scanptr = scanptr + 2
elsif ^(scanptr + 1) == '-'
token = DEC_TKN
scanptr = scanptr + 2
else
token = SUB_TKN
scanptr++
fin
break
is '+'
if ^(scanptr + 1) == '+'
token = INC_TKN
scanptr = scanptr + 2
else
token = ADD_TKN
scanptr++
fin
break
is '>'
if ^(scanptr + 1) == '>'
token = SHR_TKN
scanptr = scanptr + 2
elsif ^(scanptr + 1) == '='
token = GE_TKN
scanptr = scanptr + 2
else
token = GT_TKN
scanptr++
fin
break
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++
fin
break
is '$'
//
// Hexadecimal constant
//
token = INT_TKN
constval = 0
repeat
scanptr++
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
break
is $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; break
is 'r'
constval = $0A; break
is 't'
constval = $09; break
otherwise
constval = ^(scanptr + 2)
wend
if ^(scanptr + 3) <> $27 // '
return parse_err(@bad_cnst)
fin
scanptr = scanptr + 4
fin
break
is '"'
//
// String constant
//
token = STR_TKN
constval = scanptr
scanptr++
while ^scanptr and ^scanptr <> '"'
scanptr++
loop
if !^scanptr
return parse_err(@bad_cnst)
fin
scanptr++
break
is 0
is ';'
if token <> EOF_TKN
token = EOL_TKN
fin
break
otherwise
//
// Simple single character tokens
//
token = scanchr | $80
scanptr++
wend
fin
tknlen = scanptr - tknptr
return token
end
def rewind(ptr)#0
scanptr = ptr
end
def lookahead
word backptr, backtkn
byte prevtkn, prevlen, look
backptr = scanptr
backtkn = tknptr
prevtkn = token
prevlen = tknlen
look = scan
scanptr = backptr
tknptr = backtkn
token = prevtkn
tknlen = prevlen
return look
end
//
// Get next line of input
//
def nextln
if ^scanptr == ';'
scanptr++
scan
else
scanptr = inbuff
if lineno < numlines
cpyln(strlinbuf:[lineno], instr)
lineno++
if !(lineno & $0F); cout('.'); fin
//print(lineno);cout(':');print(numlines);cout('>');prstr(instr);crout
scan
else
//cout('<');crout
*instr = 0
//^inbuff = 0
token = DONE_TKN
fin
fin
return token
end
//
// Parser
//
//
// Constant expression parsing
//
def calc_binaryop(op)
word val1, val2
byte size1, size2, type1, type2
if not pop_val(@val2, @size2, @type2); return 0; fin
pop_val(@val1, @size1, @type1)
if type1 <> CONST_TYPE and type2 <> CONST_TYPE; return parse_err(@bad_cnst); fin
when op
is MUL_TKN
val1 = val1 * val2
break
is DIV_TKN
val1 = val1 / val2
break
is MOD_TKN
val1 = val1 % val2
break
is ADD_TKN
val1 = val1 + val2
break
is SUB_TKN
val1 = val1 - val2
break
is SHL_TKN
val1 = val1 << val2
break
is SHR_TKN
val1 = val1 >> val2
break
is AND_TKN
val1 = val1 & val2
break
is OR_TKN
val1 = val1 | val2
break
is EOR_TKN
val1 = val1 ^ val2
break
otherwise
return FALSE
wend
if size2 > size1; size1 = size2; fin
push_val(val1, size1, type1)
return TRUE
end
def parse_constterm(valptr, sizeptr)
word type
when scan
is OPEN_PAREN_TKN
type = parse_constexpr(valptr, sizeptr)
if token <> CLOSE_PAREN_TKN; return parse_err(@no_close_paren); fin
return type
is ID_TKN
is INT_TKN
is CHR_TKN
is STR_TKN
return token
wend
return FALSE
end
def parse_constval
byte mod, type, size
word idptr, ctag, value
value = 0
size = 1
mod = 0
repeat
type = parse_constterm(@value, @size)
if !type
when token
is SUB_TKN
mod = mod | 1; break
is ALT_COMP_TKN
is COMP_TKN
mod = mod | 2; break
is LOGIC_NOT_TKN
mod = mod | 4; break
is AT_TKN
mod = mod | 8; break
is ADD_TKN
break
otherwise
return 0
wend
fin
until type
when token
is CLOSE_PAREN_TKN
break
is STR_TKN
size = tknlen - 1
value = constval
type = STR_TYPE
if mod; return parse_err(@bad_op); fin
break
is CHR_TKN
size = 1
value = constval
type = CONST_TYPE
break
is INT_TKN
size = 2
value = constval
type = CONST_TYPE
break
is ID_TKN
size = 2
idptr = id_lookup(tknptr, tknlen)
if !idptr; return parse_err(@bad_cnst); fin
type = idptr->idtype
if type & ADDR_TYPE
if mod <> 8; return parse_err(@bad_cnst); fin
type = CONSTADDR_TYPE
fin
value = idptr=>idval
break
otherwise
return 0
wend
if mod & 1
value = -value
fin
if mod & 2
value = ~value
fin
if mod & 4
value = !value
fin
push_val(value, size, type)
return type
end
def parse_constexpr(valptr, sizeptr)
byte prevmatch, matchop, i, type
word optos
*valptr = 0
^sizeptr = 1
matchop = 0
optos = opsp
repeat
prevmatch = matchop
matchop = 0
if parse_constval
matchop = 1
scan
for i = 0 to bops_tblsz
if token == bops_tbl[i]
matchop = 2
if bops_prec[i] >= tos_op_prec(optos)
if !calc_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 == 0; return 0; fin
if matchop == 0 and prevmatch == 2; return parse_err(@missing_op); fin
while optos < opsp
if !calc_binaryop(pop_op); return parse_err(@bad_op); fin
loop
pop_val(valptr, sizeptr, @type)
return type
end
def parse_const(valptr)
word idptr
when scan
is CHR_TKN
is INT_TKN
*valptr = constval
break
is ID_TKN
idptr = id_lookup(tknptr, tknlen)
if !idptr; return parse_err(@bad_cnst); fin
if idptr->idtype & CONST_TYPE
*valptr = idptr=>idval
break
fin
otherwise
return 0
wend
return CONST_TYPE
end
//
// Normal expression parsing
//
def ispostop
when scan
is OPEN_PAREN_TKN
is OPEN_BRACKET_TKN
is DOT_TKN
is COLON_TKN
is PTRB_TKN
is PTRW_TKN
return TRUE
wend
return FALSE
end
def parse_term
when scan
is OPEN_PAREN_TKN
if !parse_expr
return FALSE
fin
if token <> CLOSE_PAREN_TKN; return parse_err(@no_close_paren); fin
is ID_TKN
is INT_TKN
is CHR_TKN
is STR_TKN
return TRUE
wend
return FALSE
end
def parse_value(rvalue)
byte cparams, deref, type, emit_val
word optos, idptr, value
byte const_size, ref_type
word ref_offset, const_offset
deref = rvalue
optos = opsp
type = 0
emit_val = FALSE
value = 0
//
// Parse pre-ops
//
while !parse_term
when token
is ADD_TKN
break
is BPTR_TKN
if deref
push_op(token, 0)
else
deref++
type = type | BPTR_TYPE
fin
break
is WPTR_TKN
if deref
push_op(token, 0)
else
deref++
type = type | WPTR_TYPE
fin
break
is AT_TKN
deref--
break
is SUB_TKN
is ALT_COMP_TKN
is COMP_TKN
is LOGIC_NOT_TKN
push_op(token, 0)
break
otherwise
return 0
wend
loop
//
// Determine terminal type
//
when token
is INT_TKN
is CHR_TKN
value = constval
type = type | CONST_TYPE
break
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
break
is CLOSE_PAREN_TKN
// type = type | WORD_TYPE
emit_val = TRUE
break
is STR_TKN
//
// Special case
//
emit_constr(constval, tknlen - 1)
scan
return WORD_TYPE
break
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
break
is ALT_COMP_TKN
is COMP_TKN
pop_op
value = ~value
break
is LOGIC_NOT_TKN
pop_op
value = !value
break
otherwise
cparams = FALSE
wend
loop
fin
//
// Parse post-ops
//
ref_type = type & ~PTR_TYPE
ref_offset = 0
while ispostop
when token
is OPEN_PAREN_TKN
//
// Function call
//
if emit_val
if ref_offset <> 0
emit_const(ref_offset)
emit_op($02)
ref_offset = 0
fin
if ref_type & BPTR_TYPE; emit_lb
elsif ref_type & WPTR_TYPE; emit_lw
fin
if lookahead <> CLOSE_PAREN_TKN
emit_push
fin
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 ref_type & FUNC_CONST_TYPE
emit_call(value)
else
if !emit_val
if ref_type & CONST_TYPE
emit_const(value)
elsif ref_type & VAR_TYPE
if type & LOCAL_TYPE
emit_llw(value + ref_offset)
else
emit_law(value, ref_offset)
fin
ref_offset = 0
fin
else
if cparams
emit_pull
fin
fin
emit_ical
fin
emit_val = TRUE
ref_type = 0
break
is OPEN_BRACKET_TKN
//
// Array of arrays
//
if !emit_val
if type & CONST_TYPE
emit_const(value)
elsif type & ADDR_TYPE
if type & LOCAL_TYPE
emit_localaddr(value + ref_offset)
else
emit_globaladdr(value, ref_offset)
fin
ref_offset = 0
fin
emit_val = TRUE
else
if ref_offset <> 0
emit_const(ref_offset)
emit_op($02)
ref_offset = 0
fin
fin
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 ref_type & (WPTR_TYPE | WORD_TYPE)
emit_indexword
ref_type = WPTR_TYPE
else
emit_indexbyte
ref_type = BPTR_TYPE
fin
break
is PTRB_TKN
is PTRW_TKN
//
// Structure member pointer
//
if !emit_val
if (type & CONST_TYPE)
emit_const(value)
elsif type & ADDR_TYPE
if type & LOCAL_TYPE
if ref_type & BYTE_TYPE
emit_llb(value + ref_offset)
else
emit_llw(value + ref_offset)
fin
else
if ref_type & BYTE_TYPE
emit_lab(value, ref_offset)
else
emit_law(value, ref_offset)
fin
fin
fin
emit_val = 1;
else
if ref_offset <> 0
emit_const(ref_offset)
emit_op($02)
ref_offset = 0
fin
if ref_type & BPTR_TYPE; emit_lb
elsif ref_type & WPTR_TYPE; emit_lw; fin
fin
if token == PTRB_TKN
ref_type = BPTR_TYPE
else
ref_type = WPTR_TYPE
fin
ref_offset = 0
if !parse_const(@ref_offset)
rewind(tknptr)
fin
if ref_offset <> 0
emit_const(ref_offset)
emit_op($02)
ref_offset = 0
fin
break
is DOT_TKN
is COLON_TKN
//
// Structure member offset
//
if ref_type & (VAR_TYPE | CONST_TYPE)
if token == DOT_TKN
ref_type = BYTE_TYPE
else
ref_type = WORD_TYPE
fin
else
if token == DOT_TKN
ref_type = BPTR_TYPE
else
ref_type = WPTR_TYPE
fin
fin
if parse_const(@const_offset)
ref_offset = ref_offset + const_offset
else
rewind(tknptr)
fin
if !emit_val
if type & CONST_TYPE
value = value + ref_offset
ref_offset = 0
elsif type & FUNC_TYPE
emit_globaladdr(value, ref_offset)
ref_offset = 0
emit_val = TRUE
fin
fin
break
wend
loop
if emit_val
if ref_offset <> 0
emit_const(ref_offset)
emit_op($02)
ref_offset = 0
fin
if deref
if ref_type & BPTR_TYPE
emit_lb
elsif ref_type & WPTR_TYPE
emit_lw
fin
fin
else // emit_val
if deref
if ref_type & CONST_TYPE
emit_const(value)
if ref_type & VAR_TYPE
if ref_type & BYTE_TYPE
emit_lb()
else
emit_lw()
fin
fin
elsif ref_type & FUNC_TYPE
emit_call(value)
elsif ref_type & VAR_TYPE
if type & LOCAL_TYPE
if ref_type & BYTE_TYPE
emit_llb(value + ref_offset)
else
emit_llw(value + ref_offset)
fin
else
if ref_type & BYTE_TYPE
emit_lab(value, ref_offset)
else
emit_law(value, ref_offset)
fin
fin
fin
else
if type & CONST_TYPE
emit_const(value)
elsif type & ADDR_TYPE
if type & LOCAL_TYPE
emit_localaddr(value + ref_offset)
else
emit_globaladdr(value, ref_offset)
fin
fin
fin
fin // emit_val
while optos < opsp
if !emit_unaryop(pop_op); return parse_err(@bad_op); fin
loop
if type & PTR_TYPE
ref_type = type
fin
if !ref_type
ref_type = WORD_TYPE
fin
return ref_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, elem_type, elem_size, i
word elem_offset, tag_prevbrk, tag_prevcnt, tag_else, tag_endif, tag_while, tag_wend
word tag_repeat, tag_for, tag_choice, tag_of, idptr, saveptr, addr, stepdir
if token <> END_TKN and token <> DONE_TKN and token <> OF_TKN and token <> DEFAULT_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_branch(tag_endif)
ctag_resolve(tag_else)
if !parse_expr; return FALSE; fin
tag_else = ctag_new
emit_brfls(tag_else)
until FALSE
if token == ELSE_TKN
emit_branch(tag_endif)
ctag_resolve(tag_else)
scan
while parse_stmnt
nextln
loop
ctag_resolve(tag_endif)
else
ctag_resolve(tag_else)
ctag_resolve(tag_endif)
fin
if token <> FIN_TKN; return parse_err(@no_fin); fin
break
is WHILE_TKN
tag_while = ctag_new
tag_wend = ctag_new
tag_prevcnt = cont_tag
cont_tag = tag_while
tag_prevbrk = break_tag
break_tag = tag_wend
ctag_resolve(tag_while)
if !parse_expr; return FALSE; fin
emit_brfls(tag_wend)
while parse_stmnt
nextln
loop
if token <> LOOP_TKN; return parse_err(@no_loop); fin
emit_branch(tag_while)
ctag_resolve(tag_wend)
break_tag = tag_prevbrk
cont_tag = tag_prevcnt
break
is REPEAT_TKN
tag_repeat = ctag_new
tag_prevbrk = break_tag
break_tag = ctag_new
tag_prevcnt = cont_tag
cont_tag = ctag_new
ctag_resolve(tag_repeat)
scan
while parse_stmnt
nextln
loop
if token <> UNTIL_TKN; return parse_err(@no_until); fin
ctag_resolve(cont_tag)
cont_tag = tag_prevcnt
if !parse_expr; return FALSE; fin
emit_brfls(tag_repeat)
ctag_resolve(break_tag)
break_tag = tag_prevbrk
break
is FOR_TKN
stack_loop = stack_loop + 1
tag_for = ctag_new
tag_prevcnt = cont_tag
cont_tag = tag_for
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
ctag_resolve(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, 0)
else
emit_daw(addr, 0)
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_branch(tag_for)
cont_tag = tag_prevcnt
ctag_resolve(break_tag)
emit_drop
break_tag = tag_prevbrk
stack_loop = stack_loop - 1
break
is CASE_TKN
stack_loop = stack_loop + 1
tag_prevbrk = break_tag
break_tag = ctag_new
tag_choice = ctag_new
tag_of = 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)
ctag_resolve(tag_of)
while parse_stmnt
nextln
loop
tag_of = ctag_new
if prevstmnt <> BREAK_TKN // Fall through to next OF if no break
emit_branch(tag_of)
fin
ctag_resolve(tag_choice)
tag_choice = ctag_new
break
is DEFAULT_TKN
ctag_resolve(tag_of)
tag_of = 0
scan
while parse_stmnt
nextln
loop
if token <> ENDCASE_TKN; return parse_err(@bad_stmnt); fin
break
is EOL_TKN
nextln
break
otherwise
return parse_err(@bad_stmnt)
wend
loop
if (tag_of)
ctag_resolve(tag_of)
fin
ctag_resolve(break_tag)
emit_drop
break_tag = tag_prevbrk
stack_loop = stack_loop - 1
break
is BREAK_TKN
if break_tag
emit_branch(break_tag)
else
return parse_err(@bad_stmnt)
fin
break
is CONT_TKN
if cont_tag
emit_branch(cont_tag)
else
return parse_err(@bad_stmnt)
fin
break
is RETURN_TKN
if infunc
for i = 1 to stack_loop
emit_drop
next
fin
if !parse_expr
emit_const(0)
fin
emit_leave
break
is EOL_TKN
return TRUE
is ELSE_TKN
is ELSEIF_TKN
is FIN_TKN
is LOOP_TKN
is UNTIL_TKN
is NEXT_TKN
is OF_TKN
is DEFAULT_TKN
is ENDCASE_TKN
is END_TKN
is DONE_TKN
is DEF_TKN
return FALSE
is ID_TKN
saveptr = tknptr
idptr = id_lookup(tknptr, tknlen)
if !idptr; return FALSE; fin
type = idptr->idtype
addr = idptr=>idval
if type & VAR_TYPE
elem_type = type
elem_offset = 0
if scan == DOT_TKN or token == COLON_TKN
//
// Structure member offset
//
if token == DOT_TKN
elem_type = BYTE_TYPE
else
elem_type = WORD_TYPE
fin
if !parse_const(@elem_offset)
token = ID_TKN
else
scan
fin
fin
if token == SET_TKN
if !parse_expr; return parse_err(@bad_expr); fin
if type & LOCAL_TYPE
if elem_type & BYTE_TYPE
emit_slb(addr + elem_offset)
else
emit_slw(addr + elem_offset)
fin
else
if elem_type & BYTE_TYPE
emit_sab(addr, elem_offset)
else
emit_saw(addr, elem_offset)
fin
fin
break
elsif token == INC_TKN or token == DEC_TKN
if type & LOCAL_TYPE
if elem_type & BYTE_TYPE
emit_llb(addr + elem_offset)
emit_unaryop(token)
emit_slb(addr + elem_offset)
else
emit_llw(addr + elem_offset)
emit_unaryop(token)
emit_slw(addr + elem_offset)
fin
else
if elem_type & BYTE_TYPE
emit_lab(addr, elem_offset)
emit_unaryop(token)
emit_sab(addr, elem_offset)
else
emit_law(addr, elem_offset)
emit_unaryop(token)
emit_saw(addr, elem_offset)
fin
fin
break
fin
elsif type & FUNC_TYPE
if scan == EOL_TKN
emit_call(addr)
emit_drop
break
fin
fin
tknptr = saveptr
otherwise
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
elsif token == INC_TKN or token == DEC_TKN
emit_dup
if type & XBYTE_TYPE
emit_lb
emit_unaryop(token)
emit_sb
else
emit_lw
emit_unaryop(token)
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
//cout('T')
idlen = 0
size = 1
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
if token == 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
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_struc
byte strucid[16]
byte type, idlen, struclen, constsize
word size, offset, idstr
//cout('S')
struclen = 0
if scan == ID_TKN
struclen = tknlen
if struclen > 16
struclen = 16
fin
for idlen = 0 to struclen
strucid[idlen] = ^(tknptr + idlen)
next
fin
offset = 0
while nextln == BYTE_TKN or token == WORD_TKN
size = 1
if token == BYTE_TKN
type = BYTE_TYPE
else
type = WORD_TYPE
fin
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
repeat
idlen = 0;
if token == ID_TKN
idstr = 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 idlen
idconst_add(idstr, idlen, offset)
fin
offset = offset + size
until token <> COMMA_TKN
if token <> EOL_TKN; return FALSE; fin
loop
if struclen
idconst_add(@strucid, struclen, offset)
fin
return token == END_TKN
end
def parse_vars
byte idlen, type, size
word value, idptr
//cout('V')
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)
break
is STRUC_TKN
if !parse_struc; parse_err(@bad_struc); fin
break
is BYTE_TKN
is WORD_TKN
if token == BYTE_TKN
type = BYTE_TYPE
else
type = WORD_TYPE
fin
repeat
if !parse_var(type)
return FALSE
fin
until token <> COMMA_TKN
break
is PREDEF_TKN
repeat
if scan == ID_TKN
idfunc_add(tknptr, tknlen, ctag_new)
else
return parse_err(@bad_decl)
fin
until scan <> COMMA_TKN
break
is EOL_TKN
break
otherwise
return FALSE
wend
return TRUE
end
def parse_defs
byte cfnparms
word func_tag, idptr
if token == DEF_TKN
//cout('D')
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
ctag_resolve(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(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
fin
return TRUE
elsif token == EOL_TKN
return TRUE
fin
return FALSE
end
def parse_module
idglobal_init
idlocal_init
if nextln
while parse_vars
nextln
loop
while parse_defs
nextln
loop
//cout('I')
framesize = 0
entrypoint = codeptr
emit_enter(0)
prevstmnt = 0
if token <> DONE_TKN
while parse_stmnt
nextln
loop
fin
//cout('!')
if prevstmnt <> RETURN_TKN
emit_const(0)
emit_leave
fin
if not parserr
//dumpsym(idglobal_tbl, globals)
//prstr(@entrypt_str)
//prword(entrypoint)
prstr(@bytes_compiled_str)
prword(codeptr - codebuff)
crout
keyin()
fin
return not parserr
fin
return FALSE
end
//
// Close all files
//
^$BFD8 = 0
close(0)
//
// Set memory bitmap
//
memset($BF58, 0, 24)
^$BF58 = $CF
^$BF6F = $01
//
// Init editor
//
if !(^machid & $80)
flags = uppercase | shiftlock
keyin = @keyin2
else
keyin = @keyin2e
fin
if signature == $EEEE
inittxtbuf
if argbuff
strcpy(@txtfile, @argbuff)
prstr(@txtfile)
numlines = 0
readtxt(@txtfile)
fin
signature = 0
else
cmdmode(FALSE)
fin
curschr = '+'
flags = flags | insmode
drawscrn(scrntop, scrnleft)
curson
editmode
done
Reference in New Issue View Git Blame Copy Permalink