From 766c856eedcad66641cce57437d4d205c162d9d5 Mon Sep 17 00:00:00 2001 From: David Schmenk Date: Wed, 19 Nov 2014 14:10:31 -0800 Subject: [PATCH] Add PLASMA sandbox --- src/makefile | 9 +- src/toolsrc/ed.pla | 2 +- src/toolsrc/parse.c | 14 +- src/toolsrc/sb.pla | 3742 +++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 3754 insertions(+), 13 deletions(-) create mode 100644 src/toolsrc/sb.pla diff --git a/src/makefile b/src/makefile index f14c102..81b01c3 100644 --- a/src/makefile +++ b/src/makefile @@ -6,6 +6,7 @@ PLVM02 = PLASMA.SYSTEM\#FF2000 PLVM03 = SOS.INTERP\#050000 CMD = CMD\#FF2000 ED = ED\#FF2000 +SB = SB\#FF2000 ROD = ROD\#FE1000 SIEVE = SIEVE\#FE1000 HELLO = HELLO\#FE1000 @@ -33,7 +34,7 @@ TXTTYPE = .TXT #SYSTYPE = \#FF2000 #TXTTYPE = \#040000 -all: $(PLASM) $(PLVM) $(PLVM01) $(PLVM02) $(PLVM03) $(CMD) $(PROFILE) $(ED) $(ROD) $(SIEVE) $(HGR1) +all: $(PLASM) $(PLVM) $(PLVM01) $(PLVM02) $(PLVM03) $(CMD) $(PROFILE) $(ED) $(SB) $(ROD) $(SIEVE) $(HGR1) clean: -rm *FE1000 *FF2000 $(PLASM) $(PLVM) $(PLVM01) $(PLVM02) $(PLVM03) @@ -82,10 +83,14 @@ test: samplesrc/test.pla samplesrc/testlib.pla $(PLVM) $(PLASM) acme --setpc 4094 -o $(TESTLIB) samplesrc/testlib.a ./$(PLVM) TEST -$(ED): toolsrc/ed.pla $(PLVM02) $(PLASM) +$(ED): toolsrc/ed.pla $(PLVM02) $(PLASM) toolsrc/ed.pla ./$(PLASM) -A < toolsrc/ed.pla > toolsrc/ed.a acme --setpc 8192 -o $(ED) toolsrc/ed.a +$(SB): toolsrc/sb.pla $(PLVM02) $(PLASM) toolsrc/sb.pla + ./$(PLASM) -A < toolsrc/sb.pla > toolsrc/sb.a + acme --setpc 8192 -o $(SB) toolsrc/sb.a + $(ROD): samplesrc/rod.pla $(PLVM02) $(PLASM) ./$(PLASM) -AM < samplesrc/rod.pla > samplesrc/rod.a acme --setpc 4094 -o $(ROD) samplesrc/rod.a diff --git a/src/toolsrc/ed.pla b/src/toolsrc/ed.pla index 910dbc5..54e42e9 100755 --- a/src/toolsrc/ed.pla +++ b/src/toolsrc/ed.pla @@ -2,7 +2,7 @@ // Global constants // const false = 0 -const true = !false +const true = 1 // // Hardware constants // diff --git a/src/toolsrc/parse.c b/src/toolsrc/parse.c index cb94b89..6a98080 100755 --- a/src/toolsrc/parse.c +++ b/src/toolsrc/parse.c @@ -256,7 +256,7 @@ int parse_value(int rvalue) } else if (scantoken == CLOSE_PAREN_TOKEN) { - // type |= WORD_TYPE; + // type |= WORD_TYPE; emit_value = 1; } else @@ -867,16 +867,10 @@ int parse_stmnt(void) int i; for (i = 0; i < stack_loop; i++) emit_drop(); - if (!parse_expr()) - emit_const(0); - emit_leave(); - } - else - { - if (!parse_expr()) - emit_const(0); - emit_ret(); } + if (!parse_expr()) + emit_const(0); + emit_ret(); break; case EOL_TOKEN: case COMMENT_TOKEN: diff --git a/src/toolsrc/sb.pla b/src/toolsrc/sb.pla new file mode 100644 index 0000000..ecf7eba --- /dev/null +++ b/src/toolsrc/sb.pla @@ -0,0 +1,3742 @@ +// +// Global constants +// +const false = 0 +const true = 1 +// +// Hardware constants +// +const csw = $0036 +const speaker = $C030 +const showgraphics = $C050 +const showtext = $C051 +const showfull = $C052 +const showmix = $C053 +const showpage1 = $C054 +const showpage2 = $C055 +const showlores = $C056 +const showhires = $C057 +const pushbttn1 = $C061 +const pushbttn2 = $C062 +const pushbttn3 = $C063 +const keyboard = $C000 +const keystrobe = $C010 +const keyenter = $8D +const keyspace = $A0 +const keyarrowup = $8B +const keyarrowdown = $8A +const keyarrowleft = $88 +const keyarrowright = $95 +const keyescape = $9B +const keyctrla = $81 +const keyctrlb = $82 +const keyctrlc = $83 +const keyctrld = $84 +const keyctrle = $85 +const 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 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 = $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 +// +// Argument buffer (must be first declared variables) +// +word = $EEEE +byte = 32 // buffer length +byte[32] argbuff = "" +// +// 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 0.9 " +byte errorstr = "ERROR: $" +byte okstr = "OK" +byte outofmem = "OUT OF MEMORY!" +byte losechng = "LOSE CHANGES TO FILE (Y/N)?" +byte untitled = "UNTITLED" +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 +// +// Compiler variables +// +// +// Tokens +// +const ID_TKN = $D6 // V +const CHR_TKN = $C3 // C +const INT_TKN = $C9 // I +const STR_TKN = $D3 // S +const EOL_TKN = $02 +const EOF_TKN = $01 +const ERR_TKN = $00 +// +// Binary operand operators +// +const SET_TKN = $BD // = +const ADD_TKN = $AB // + +const SUB_TKN = $AD // - +const MUL_TKN = $AA // * +const DIV_TKN = $AF // / +const MOD_TKN = $A5 // % +const OR_TKN = $BF // ? +const EOR_TKN = $DE // ^ +const AND_TKN = $A6 // & +const SHR_TKN = $D2 // R +const SHL_TKN = $CC // L +const GT_TKN = $BE // > +const GE_TKN = $C8 // H +const LT_TKN = $BC // < +const LE_TKN = $C2 // B +const NE_TKN = $D5 // U +const EQ_TKN = $C5 // E +const LOGIC_AND_TKN = $CE // N +const LOGIC_OR_TKN = $CF // O +// +// Unary operand operators +// +const AT_TKN = $C0 // @ +const DOT_TKN = $AE // . +const COLON_TKN = $BA // : +const NEG_TKN = $AD // - +const COMP_TKN = $A3 // # +const LOGIC_NOT_TKN = $A1 // ! +const BPTR_TKN = $DE // ^ +const WPTR_TKN = $AA // * +const 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 DONE_TKN = $98 +const RETURN_TKN = $99 +const BREAK_TKN = $9A +const START_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 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 = "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 = "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 +// +// Symbol table variables +// +const idglobal_tblsz = 2048 +const idlocal_tblsz = 512 +const idglobal_tbl = $1600 +const idlocal_tbl = $1E00 +const ctag_max = 640 +const ctag_value = $800 +const ctag_flags = $D80 +const idval = 0 +const idtype = 2 +const idname = 3 +const idrecsz = 4 +word globals = 0 +word datasize = 0 +word lastglobal +byte locals = 0 +word framesize = 0 +word lastlocal +const resolved = 1 +const is_ctag = $8000 +const mask_ctag = $7FFF +word codetag = -1 +word codeptr, entrypoint = 0 +byte lastop = $FF +// +// Scanner variables +// +const inbuff = $0200 +const instr = $01FF +byte token, tknlen +byte parserrpos, parserr = 0 +word scanptr, tknptr, parserrln +word constval +word lineno = 0 +// +// Compiler output messages +// +byte entrypt_str[] = "START: " +byte comp_ok_msg[] = "COMPILATION COMPLETE" +byte dup_id[] = "DUPLICATE IDENTIFIER" +byte undecl_id[] = "UNDECLARED IDENTIFIER" +byte bad_cnst[] = "BAD CONSTANT" +byte bad_offset[] = "BAD STRUCT OFFSET" +byte bad_decl[] = "BAD DECLARATION" +byte bad_op[] = "BAD OPERATION" +byte bad_stmnt[] = "BAD STATMENT" +byte bad_expr[] = "BAD EXPRESSION" +byte bad_syntax[] = "BAD SYNTAX" +byte estk_overflw[] = "EVAL STACK OVERFLOW" +byte estk_underflw[] = "EVAL STACK UNDERFLOW" +byte local_overflw[] = "LOCAL FRAME OVERFLOW" +byte global_sym_overflw[] = "GLOBAL SYMBOL TABLE OVERFLOW" +byte local_sym_overflw[] = "LOCAL SYMBOL TABLE OVERFLOW" +byte ctag_full[] = "CODE LABEL OVERFLOW" +byte no_close_paren[] = "MISSING CLOSING PAREN" +byte no_close_bracket[] = "MISSING CLOSING BRACKET" +byte missing_op[] = "MISSING OPERAND" +byte no_fin[] = "MISSING FIN" +byte no_loop[] = "MISSING LOOP" +byte no_until[] = "MISSING UNTIL" +byte no_done[] = "MISSING DONE" +byte no_local_init[] = "NO INITIALIZED LOCALS" +// +// Runtime functions +// +byte runtime0[] = "call" +byte RUNTIME0[] = "CALL" +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 +predef 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 +// +// CALL 6502 ROUTINE +// CALL(ADDR, AREG, XREG, YREG, STATUS) +// +asm call +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 + STA ESTKL,X + STY ESTKH,X + PLP + RTS +JMPTMP JMP (TMP) +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 + JSR $BF00 +CMD: !BYTE 00 +PARAMS: !WORD 0000 + LDY #$00 + STA ESTKL,X + STY ESTKH,X + RTS +end +// SET MEMORY TO VALUE +// MEMSET(ADDR, SIZE, VALUE) +// With optimizations from Peter Ferrie +// +asm memset + LDY #$00 + LDA ESTKL+2,X + STA DSTL + LDA ESTKH+2,X + STA DSTH + INC ESTKL+1,X + INC ESTKH+1,X +SETMLPL CLC + LDA ESTKL,X +SETMLPH DEC ESTKL+1,X + BNE + + DEC ESTKH+1,X + BEQ SETMEX ++ STA (DST),Y + INY + BNE + + INC DSTH ++ BCS SETMLPL + SEC + LDA ESTKH,X + BCS SETMLPH +SETMEX INX + INX + RTS +end +// +// COPY MEMORY +// MEMCPY(DSTADDR, SRCADDR, SIZE) +// +asm memcpy + 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 + 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 + INC ESTKH-2,X + DEC DSTH + DEC SRCH + LDY #$FF +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 + LDA ESTKL,X + 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 + STA ESTKL,X + STY ESTKH,X + RTS +end +// +// PRINT STRING +// PRSTR(STR) +// +asm prstr + LDY #$00 + LDA ESTKL,X + STA SRCL + LDA ESTKH,X + STA SRCH + LDA (SRC),Y + STA TMP + BEQ ++ + BIT ROMEN +- INY + LDA (SRC),Y + ORA #$80 + JSR $FDED + CPY TMP + BNE - + BIT LCRDEN+LCBNK2 +++ RTS +end +// +// READ STRING +// STR = RDSTR(PROMPTCHAR) +// +asm rdstr + 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 + 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 + LDA ESTKL,X + AND #$7F + CMP #'a' + BCC + + CMP #'z'+1 + BCS + + SEC + SBC #$20 ++ STA ESTKL,X + RTS +end +asm clrhibit(strptr) + LDA ESTKL,X + STA SRCL + LDA ESTKH,X + STA SRCH + LDY #$00 + LDA (SRC),Y + BEQ + + TAY +CLHILP LDA (SRC),Y + AND #$7F + STA (SRC),Y + DEY + BNE CLHILP ++ RTS +end +asm sethibit(strptr) + LDA ESTKL,X + STA SRCL + LDA ESTKH,X + STA SRCH + 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) + LDA ESTKL,X + STA DSTL + LDA ESTKH,X + STA DSTH + INX + LDA ESTKL,X + STA SRCL + LDA ESTKH,X + STA SRCH + 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 isalpha(c) +// if c >= 'A' and c <= 'Z' +// return true +// elsif c >= 'a' and c <= 'z' +// return true +// elsif c == '_' +// return true +// fin +// return false +//end +asm isalpha + LDY #$00 + LDA ESTKL,X + CMP #'A' + BCC ISALRET + CMP #'Z'+1 + BCS + + DEY + BNE ISALRET ++ CMP #'a' + BCC ISALRET + CMP #'z'+1 + BCS + + DEY + BNE ISALRET ++ CMP #'_' + BNE ISALRET + DEY +ISALRET STY ESTKL,X + STY ESTKH,X + RTS +end +//def isnum(c) +// if c >= '0' and c <= '9' +// return true +// fin +// return false +//end +asm isnum + LDY #$00 + LDA ESTKL,X + CMP #'0' + BCC + + CMP #'9'+1 + BCS + + DEY ++ STY ESTKL,X + STY ESTKH,X + RTS +end +//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 + LDY #$00 + LDA ESTKL,X + CMP #'0' + BCC ISANRET + CMP #'9'+1 + BCS + + DEY + BNE ISANRET ++ CMP #'A' + BCC ISANRET + CMP #'Z'+1 + BCS + + DEY + BNE ISANRET ++ CMP #'a' + BCC ISANRET + CMP #'z'+1 + BCS + + DEY + BNE ISANRET ++ CMP #'_' + BNE ISANRET + DEY +ISANRET STY ESTKL,X + STY ESTKH,X + RTS +end +// +// 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[12] + + params.0 = 1 + params:1 = path + perr = syscall($C1, @params) + return perr +end +def newline(refnum, emask, nlchar) + byte params[4] + + params.0 = 3 + params.1 = refnum + params.2 = emask + params.3 = nlchar + perr = syscall($C9, @params) + return perr +end + +//===================================== +// +// Editor +// +//===================================== + +def crout + cout($0D) +end +def bell + return call($FBDD, 0, 0, 0, 0) +end +// +// Memory management routines +// +def strcpy(srcstr, dststr) + byte strlen + + strlen = ^srcstr + while (srcstr).[strlen] == $8D or (srcstr).[strlen] == $A0 + strlen = strlen - 1 + loop + ^dststr = strlen + 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) + 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 + word i + + memset(strheapmap, strheapmsz, 0) + memset(strlinbuf, maxfill * 2, @nullstr) + 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) + byte i, chr + + for i = ^strptr downto 1 + chr = (strptr).[i] + if chr & $E0 == $E0 + (strptr).[i] = chr - $E0 + fin + next +end +def strlower(strptr) + byte i, chr + + for i = ^strptr downto 1 + chr = (strptr).[i] + if chr & $E0 == $00 + (strptr).[i] = chr + $E0 + fin + next +end +def txtupper + word i, strptr + + flags = flags | uppercase + for i = numlines - 1 downto 0 + strupper(strlinbuf:[i]) + next +end +def txtlower + word i, strptr + + flags = flags & ~uppercase + for i = numlines - 1 downto 0 + strlower(strlinbuf:[i]) + next +end +def prbyte(h) + cout('$') + return call($FDDA, h, 0, 0, 0) +end +def prword(h) + cout('$') + return 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 = place - 1 + loop + numstr[place] = i + '0' + place = place - 1 + if sign + numstr[place] = '-' + place = place - 1 + fin + numstr[place] = 6 - place + return prstr(@numstr[place]) +end +def nametostr(namestr, len, strptr) + ^strptr = len + return memcpy(strptr + 1, namestr, len) +end +// +// File routines +// +def readtxt(filename) + byte txtbuf[81], refnum, i, j + + refnum = open(filename, iobuffer) + if refnum + newline(refnum, $7F, $0D) + repeat + txtbuf = read(refnum, @txtbuf + 1, maxlnlen) + if txtbuf + sethibit(@txtbuf) + if flags & uppercase; strupper(@txtbuf); fin + strlinbuf:[numlines] = newstr(@txtbuf) + numlines = numlines + 1 + fin + if !(numlines & $0F); cout('.'); fin + until txtbuf == 0 or numlines == maxlines + close(refnum) + // + // 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 = numlines + 1 + fin + fin +end +def writetxt(filename) + byte txtbuf[81], refnum + byte j, chr + word i, strptr + + destroy(filename) + create(filename, $C3, $04, $00) // full access, TXT file + refnum = open(filename, iobuffer) + if refnum == 0 + return + 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 + 1 + txtbuf[txtbuf] = $0D + write(refnum, @txtbuf + 1, txtbuf) + if !(i & $0F); cout('.'); fin + next + return close(refnum) +end +// +// Screen routines +// +def clrscrn + return call($FC58, 0, 0, 0, 0) +end +def drawrow(row, ofst, strptr) + 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, 40 - numchars, $A0A0) + fin + return memcpy(scrnptr, strptr + ofst + 1, numchars) +end +def drawscrn(toprow, ofst) + byte row, numchars + word numchars, strptr, scrnptr + + if ofst + for row = 0 to 23 + strptr = strlinbuf:[toprow + row] + scrnptr = txtscrn[row] + if ofst >= ^strptr + numchars = 0 + else + numchars = ^strptr - ofst + fin + if numchars >= 40 + numchars = 40 + else + memset(scrnptr + numchars, 40 - numchars, $A0A0) + fin + memcpy(scrnptr, strptr + ofst + 1, numchars) + next + else + for row = 0 to 23 + strptr = strlinbuf:[toprow + row] + scrnptr = txtscrn[row] + numchars = ^strptr + if numchars >= 40 + numchars = 40 + else + memset(scrnptr + numchars, 40 - numchars, $A0A0) + fin + memcpy(scrnptr, strptr + 1, numchars) + next + fin +end +def cursoff + if flags & showcurs + ^cursptr = underchr + flags = flags & ~showcurs + fin +end +def curson + if !(flags & showcurs) + cursptr = txtscrn[cursy] + cursx + underchr = ^cursptr + ^cursptr = curschr + flags = flags | showcurs + fin +end +def cursflash + if flags & showcurs + if flash == 0 + ^cursptr = curschr + elsif flash == 128 + ^cursptr = underchr + fin + flash = flash + 1 + fin +end +def redraw + cursoff + drawscrn(scrntop, scrnleft) + curson +end +def curshome + cursoff + cursrow = 0 + curscol = 0 + cursx = 0 + cursy = 0 + scrnleft = 0 + scrntop = 0 + drawscrn(scrntop, scrnleft) + return curson +end +def cursend + cursoff + if numlines > 23 + cursrow = numlines - 1 + cursy = 23 + scrntop = cursrow - 23 + else + cursrow = numlines - 1 + cursy = numlines - 1 + scrntop = 0 + fin + curscol = 0 + cursx = 0 + scrnleft = 0 + drawscrn(scrntop, scrnleft) + return curson +end +def cursup + if cursrow > 0 + cursoff + cursrow = cursrow - 1 + if cursy > 0 + cursy = cursy - 1 + else + scrntop = cursrow + drawscrn(scrntop, scrnleft) + fin + curson + fin +end +def pgup + byte i + + for i = pgjmp downto 0 + cursup + next +end +def cursdown + if cursrow < numlines - 1 + cursoff + cursrow = cursrow + 1 + if cursy < 23 + cursy = cursy + 1 + else + scrntop = cursrow - 23 + drawscrn(scrntop, scrnleft) + fin + curson + fin +end +def pgdown + byte i + + for i = pgjmp downto 0 + cursdown + next +end +def cursleft + if curscol > 0 + cursoff + curscol = curscol - 1 + if cursx > 0 + cursx = cursx - 1 + else + scrnleft = curscol + drawscrn(scrntop, scrnleft) + fin + curson + fin +end +def pgleft + byte i + + for i = 7 downto 0 + cursleft + next +end +def cursright + if curscol < 80 + cursoff + curscol = curscol + 1 + if cursx < 39 + cursx = cursx + 1 + else + scrnleft = curscol - 39 + drawscrn(scrntop, scrnleft) + fin + curson + fin +end +def pgright + byte i + + for i = 7 downto 0 + cursright + next +end +// +// Keyboard routines +// +def keyin2e + repeat + cursflash + until ^keyboard >= 128 + return ^keystrobe +end +def keyin2 + byte key + + repeat + cursflash + key = ^keyboard + if key == keyctrll + ^keystrobe + flags = flags ^ shiftlock + key = 0 + fin + until key >= 128 + ^keystrobe + if key == keyctrln + key = $DB // [ + elsif key == keyctrlp + key = $DF // _ + elsif key == keyctrlb + key = $DC // \ + elsif key == keyarrowleft + if ^pushbttn3 < 128 + key = $FF + fin + elsif key >= $C0 and flags < shiftlock + if ^pushbttn3 < 128 + if key == $C0 + key = $D0 // P + elsif key == $DD + key = $CD // M + elsif key == $DE + key = $CE // N + fin + else + key = key | $E0 + fin + fin + return key +end +// +// Printer routines +// +def printtxt(slot) + byte txtbuf[80] + word i, scrncsw + + scrncsw = *(csw) + *(csw) = $C000 | (slot << 8) + for i = 0 to numlines - 1 + cpyln(strlinbuf:[i], @txtbuf) + prstr(@txtbuf) + crout + next + *(csw) = scrncsw +end +def openline(row) + if numlines < maxlines + memcpy(@strlinbuf:[row + 1], @strlinbuf:[row], (numlines - row) * 2) + strlinbuf:[row] = @nullstr + numlines = numlines + 1 + flags = flags | changed + return 1 + fin + bell + return 0 +end +def cutline + freestr(cutbuf) + cutbuf = strlinbuf:[cursrow] + memcpy(@strlinbuf:[cursrow], @strlinbuf:[cursrow + 1], (numlines - cursrow) * 2) + if numlines > 1 + numlines = numlines - 1 + fin + flags = flags | changed + if cursrow == numlines + cursup + fin + return redraw +end +def pasteline + if cutbuf and numlines < maxlines + memcpy(@strlinbuf:[cursrow + 1], @strlinbuf:[cursrow], (numlines - cursrow) * 2) + strlinbuf:[cursrow] = newstr(cutbuf) + numlines = numlines + 1 + flags = flags | changed + redraw + else + bell + fin +end +def joinline + byte joinstr[80], joinlen + + if cursrow < numlines - 1 + strcpy(strlinbuf:[cursrow], @joinstr) + joinlen = joinstr + ^(strlinbuf:[cursrow + 1]) + if joinlen < 80 + memcpy(@joinstr + joinstr + 1, strlinbuf:[cursrow + 1] + 1, ^(strlinbuf:[cursrow + 1])) + joinstr = joinlen + freestr(strlinbuf:[cursrow]) + strlinbuf:[cursrow] = newstr(@joinstr) + freestr(strlinbuf:[cursrow + 1]) + numlines = numlines - 1 + memcpy(@strlinbuf:[cursrow + 1], @strlinbuf:[cursrow + 2], (numlines - cursrow) * 2) + flags = flags | changed + redraw + else + bell + fin + fin +end +def splitline + byte splitstr[80], splitlen + + if openline(cursrow + 1) + if curscol + splitlen = ^(strlinbuf:[cursrow]) + if curscol < splitlen - 1 + memcpy(@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, 80, $A0A0) + strcpy(strlinbuf:[cursrow], @editstr) + undoline = strlinbuf:[cursrow] + strlinbuf:[cursrow] = @editstr + repeat + if key >= keyspace + if key == keydelete + if curscol > 0 + if curscol <= editstr + memcpy(@editstr[curscol], @editstr[curscol + 1], editstr - curscol) + editstr = editstr - 1 + fin + curscol = curscol - 1 + cursoff + if cursx > 0 + cursx = cursx - 1 + drawrow(cursy, scrnleft, @editstr) + else + scrnleft = scrnleft - 1 + drawscrn(scrntop, scrnleft) + fin + curson + fin + elsif curscol < maxlnlen + curscol = curscol + 1 + cursx = cursx + 1 + if flags & insmode + if editstr < maxlnlen or editstr.maxlnlen == $A0 + editstr = editstr + 1 + if curscol >= editstr + editstr = curscol + else + memcpy(@editstr[curscol + 1], @editstr[curscol], editstr - curscol) + fin + else + curscol = curscol - 1 + cursx = cursx - 1 + key = editstr[curscol] + bell + fin + else + if curscol > editstr + editstr = curscol + fin + fin + editstr[curscol] = caseconv(key) + cursoff + if cursx <= 39 + drawrow(cursy, scrnleft, @editstr) + else + scrnleft = scrnleft + 1 + cursx = 39 + drawscrn(scrntop, scrnleft) + fin + curson + else + bell + fin + elsif key == keyctrld + if curscol < editstr + strcpy(@editstr, undoline) + memcpy(@editstr[curscol + 1], @editstr[curscol + 2], editstr - curscol) + editstr = editstr - 1 + cursoff + drawrow(cursy, scrnleft, @editstr) + curson + fin + elsif key == keyctrlr + strcpy(undoline, @editstr) + cursoff + drawrow(cursy, scrnleft, @editstr) + curson + fin + key = keyin() + until not editkey(key) + if editstr + strlinbuf:[cursrow] = newstr(@editstr) + else + strlinbuf:[cursrow] = @nullstr + fin + freestr(undoline) + fin + return key +end +def editmode + repeat + when editline(keyin()) + is keyarrowup + cursup; 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 = numlines + 1 + fin + cursdown + is keyctrlo + openline(cursrow) + redraw + break + is keyenter + if flags & insmode + splitline + else + openline(cursrow + 1) + cursdown + 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 + redraw + break + wend + until false +end +// +// Command mode +// +def prfiles(optpath) + byte path[64] + byte refnum + byte firstblk + byte entrylen, entriesblk + byte i, type, len + word entry, filecnt + + if ^optpath + strcpy(optpath, @path) + else + getpfx(@path) + prstr(@path) + crout + fin + refnum = open(@path, iobuffer) + if perr + return perr + fin + firstblk = 1 + repeat + if read(refnum, databuff, 512) == 512 + entry = databuff + 4 + if firstblk + entrylen = databuff.$23 + entriesblk = databuff.$24 + filecnt = databuff:$25 + entry = entry + entrylen + fin + for i = firstblk to entriesblk + type = ^entry + if type <> 0 + len = type & $0F + ^entry = len + prstr(entry) + if type & $F0 == $D0 // Is it a directory? + cout('/') + len = len + 1 + fin + for len = 20 - len downto 1 + cout(' ') + next + filecnt = filecnt - 1 + fin + entry = entry + entrylen + next + firstblk = 0 + else + filecnt = 0 + fin + until filecnt == 0 + close(refnum) + crout + return 0 +end +def striplead(strptr, chr) + while ^strptr and ^(strptr + 1) == chr + memcpy(strptr + 1, strptr + 2, ^strptr) + ^strptr = ^strptr - 1 + loop +end +def parsecmd(strptr) + byte cmd + + cmd = 0 + striplead(strptr, ' ') + if ^strptr + cmd = ^(strptr + 1) + memcpy(strptr + 1, strptr + 2, ^strptr) + ^strptr = ^strptr - 1 + 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 + if chkchng + exit + fin +end +def cmdmode + byte slot + word cmdptr + + clrscrn + prstr(@version) + 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 + strcpy(cmdptr, @txtfile) + readtxt(@txtfile) + if numlines == 0; numlines = 1; fin + flags = flags & ~changed + fin + break + is 'W' + if ^cmdptr + strcpy(cmdptr, @txtfile) + fin + writetxt(@txtfile) + //if flags & changed; 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(@untitled, @txtfile) + 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 + else + crout + (entrypoint)() + fin + else + (entrypoint)() + 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 +// +def ctag_new + if codetag >= ctag_max + return parse_err(@ctag_full) + fin + codetag = codetag + 1 + ctag_value:[codetag] = 0 + ctag_flags.[codetag] = 0 + return codetag | is_ctag +end +def ctag_resolve(tag, addr) + word updtptr, nextptr + + tag = tag & mask_ctag + if ctag_flags.[tag] & resolved + return parse_err(@dup_id) + fin + updtptr = ctag_value:[tag] + while updtptr + // + // Update list of addresses needing resolution + // + nextptr = *updtptr + *updtptr = addr + updtptr = nextptr + loop + ctag_value:[tag] = addr + ctag_flags.[tag] = ctag_flags.[tag] | resolved +end + +// +// Emit data/bytecode +// +def emit_byte(bval) + ^codeptr = bval + codeptr = codeptr + 1 +end +def emit_word(wval) + *codeptr = wval + codeptr = codeptr + 2 +end +def emit_fill(size) + memset(codeptr, size, 0) + codeptr = codeptr + size +end +def emit_codetag(tag) + return ctag_resolve(tag, codeptr) +end +def emit_op(op) + lastop = op + return emit_byte(op) +end +def emit_tag(tag) + word updtptr + + if tag & is_ctag + tag = tag & mask_ctag + updtptr = ctag_value:[tag] + if !(ctag_flags.[tag] & resolved) + // + // Add to list of tags needing resolution + // + ctag_value:[tag] = codeptr + fin + emit_word(updtptr) + else + emit_word(tag + codebuff) + fin +end +def emit_iddata(value, size, namestr) + return emit_fill(size) +end +def emit_data(vartype, consttype, constval, constsize) + byte i + word size, chrptr + + if consttype == 0 + size = constsize + emit_fill(constsize) + elsif consttype == STR_TYPE + size = constsize + chrptr = constval + constsize = constsize - 1 + emit_byte(constsize) + while constsize > 0 + emit_byte(^chrptr) + chrptr = chrptr + 1 + constsize = constsize - 1 + loop + else + if vartype == WORD_TYPE + size = 2 + emit_word(constval) + else + size = 1 + emit_byte(constval) + fin + fin + return size +end +def emit_const(cval) + if cval == 0 + emit_op($00) + elsif cval > 0 and cval < 256 + emit_op($2A) + emit_byte(cval) + else + emit_op($2C) + emit_word(cval) + fin +end +def emit_lb + return emit_op($60) +end +def emit_lw + return emit_op($62) +end +def emit_llb(index) + emit_op($64) + return emit_byte(index) +end +def emit_llw(index) + emit_op($66) + return emit_byte(index) +end +def emit_lab(tag) + emit_op($68) + return emit_tag(tag) +end +def emit_law(tag) + emit_op($6A) + return emit_tag(tag) +end +def emit_sb + return emit_op($70) +end +def emit_sw + return emit_op($72) +end +def emit_slb(index) + emit_op($74) + return emit_byte(index) +end +def emit_slw(index) + emit_op($76) + return emit_byte(index) +end +def emit_dlb(index) + emit_op($6C) + return emit_byte(index) +end +def emit_dlw(index) + emit_op($6E) + return emit_byte(index) +end +def emit_sab(tag) + emit_op($78) + return emit_tag(tag) +end +def emit_saw(tag) + emit_op($7A) + return emit_tag(tag) +end +def emit_dab(tag) + emit_op($7C) + return emit_tag(tag) +end +def emit_daw(tag) + emit_op($7E) + return emit_tag(tag) +end +def emit_call(tag, cparams) + emit_op($54) + return emit_tag(tag) +end +def emit_ical(cparams) + emit_op($56) + return emit_byte(cparams) +end +def emit_push + emit_op($34) +end +def emit_pull + // + // Skip if last op was push + // + if lastop == $34 + codeptr = codeptr - 1 + lastop = $FF + else + emit_op($36) + fin +end +def emit_localaddr(index) + emit_op($28) + return emit_byte(index) +end +def emit_globaladdr(tag) + emit_op($26) + return emit_tag(tag) +end +def emit_indexbyte + return emit_op($2E) +end +def emit_indexword + return emit_op($1E) +end +def emit_unaryop(op) + when op + is NEG_TKN + emit_op($10); break + 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) + emit_op($4E) + return emit_tag(tag) +end +def emit_brfls(tag) + emit_op($4C) + return emit_tag(tag) +end +def emit_brgt(tag) + emit_op($38) + return emit_tag(tag) +end +def emit_brlt(tag) + emit_op($3A) + return emit_tag(tag) +end +def emit_brne(tag) + emit_op($3E) + return emit_tag(tag) +end +def emit_branch(tag) + emit_op($50) + return emit_tag(tag) +end +def emit_drop + return emit_op($30) +end +def emit_leave + if framesize + emit_op($5A) + else + emit_op($5C) + fin +end +def emit_enter(cparams) + 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 +def emit_start + // + // Save address + // + entrypoint = codeptr + emit_byte(emit_start.[0]) + emit_byte(emit_start.[1]) + return emit_op(emit_start.[2]) +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 = idcnt - 1 + loop + return 0 +end +def dumpsym(idptr, idcnt) + while idcnt + prword((idptr):idval) + cout(' ') + prbyte((idptr).idtype) + cout(' ') + prstr(@(idptr).idname) + cout('=') + if (idptr).idtype & ADDR_TYPE + if (idptr):idval & is_ctag + prword(ctag_value:[(idptr):idval & mask_ctag]) + else + prword((idptr):idval + codebuff) + fin + else + prword((idptr):idval) + fin + crout + idptr = idptr + (idptr).idname + idrecsz + idcnt = idcnt - 1 + loop +end +def id_lookup(nameptr, len) + word idptr + + idptr = idmatch(nameptr, len, idlocal_tbl, locals) + if idptr + return idptr + fin + idptr = idmatch(nameptr, len, idglobal_tbl, globals) + if idptr + return idptr + fin + return parse_err(@undecl_id) +end +def idglobal_lookup(nameptr, len) + return idmatch(nameptr, len, idglobal_tbl, globals) +end +def idlocal_add(namestr, len, type, size) + if idmatch(namestr, len, @idlocal_tbl, locals) + return parse_err(@dup_id) + fin + (lastlocal):idval = framesize + (lastlocal).idtype = type | LOCAL_TYPE + nametostr(namestr, len, lastlocal + idname) + locals = locals + 1 + lastlocal = lastlocal + idrecsz + len + if lastlocal > idlocal_tbl + idlocal_tblsz + prstr(@local_sym_overflw) + exit + fin + framesize = framesize + size + if framesize > 255 + prstr(@local_overflw) + return false + fin + return true +end +def iddata_add(namestr, len, type, size) + if idmatch(namestr, len, idglobal_tbl, globals) + return parse_err(@dup_id) + fin + (lastglobal):idval = datasize + (lastglobal).idtype = type + nametostr(namestr, len, lastglobal + idname) + emit_iddata(datasize, size, lastglobal + idname) + globals = globals + 1 + lastglobal = lastglobal + idrecsz + len + if lastglobal > idglobal_tbl + idglobal_tblsz + prstr(@global_sym_overflw) + exit + fin + datasize = datasize + size + return true +end +def iddata_size(type, varsize, initsize) + if varsize > initsize + datasize = datasize + emit_data(0, 0, 0, varsize - initsize) + else + datasize = datasize + initsize + fin +// if datasize <> codeptr - codebuff +// prstr(@emiterr) +// keyin() +// fin +end +def idglobal_add(namestr, len, type, value) + if idmatch(namestr, len, idglobal_tbl, globals) + return parse_err(@dup_id) + fin + (lastglobal):idval = value + (lastglobal).idtype = type + nametostr(namestr, len, lastglobal + idname) + globals = globals + 1 + lastglobal = lastglobal + idrecsz + len + if lastglobal > idglobal_tbl + idglobal_tblsz + prstr(@global_sym_overflw) + exit + fin + return true +end +def idfunc_add(namestr, len, tag) + return idglobal_add(namestr, len, FUNC_TYPE, tag) +end +def idconst_add(namestr, len, value) + return idglobal_add(namestr, len, CONST_TYPE, value) +end +def idglobal_init + word ctag + + lineno = 0 + parserr = 0 + codeptr = codebuff + lastop = $FF + entrypoint = 0 + datasize = 0 + globals = 0 + lastglobal = idglobal_tbl + codetag = -1 + ctag = ctag_new + idfunc_add(@runtime0 + 1, runtime0, ctag) + idfunc_add(@RUNTIME0 + 1, RUNTIME0, ctag) + ctag_resolve(ctag, @call) + ctag = ctag_new + idfunc_add(@runtime1 + 1, runtime1, ctag) + idfunc_add(@RUNTIME1 + 1, RUNTIME1, ctag) + ctag_resolve(ctag, @syscall) + ctag = ctag_new + idfunc_add(@runtime2 + 1, runtime2, ctag) + idfunc_add(@RUNTIME2 + 1, RUNTIME2, ctag) + ctag_resolve(ctag, @memset) + ctag = ctag_new + idfunc_add(@runtime3 + 1, runtime3, ctag) + idfunc_add(@RUNTIME3 + 1, RUNTIME3, ctag) + ctag_resolve(ctag, @memcpy) + ctag = ctag_new + idfunc_add(@runtime4 + 1, runtime4, ctag) + idfunc_add(@RUNTIME4 + 1, RUNTIME4, ctag) + ctag_resolve(ctag, @cout) + ctag = ctag_new + idfunc_add(@runtime5 + 1, runtime5, ctag) + idfunc_add(@RUNTIME5 + 1, RUNTIME5, ctag) + ctag_resolve(ctag, @cin) + ctag = ctag_new + idfunc_add(@runtime6 + 1, runtime6, ctag) + idfunc_add(@RUNTIME6 + 1, RUNTIME6, ctag) + ctag_resolve(ctag, @prstr) + ctag = ctag_new + idfunc_add(@runtime7 + 1, runtime7, ctag) + idfunc_add(@RUNTIME7 + 1, RUNTIME7, ctag) + ctag_resolve(ctag, @rdstr) +end +def idlocal_init + locals = 0 + framesize = 0 + lastlocal = idlocal_tbl +end +// +// Alebraic op to stack op +// +def push_op(op, prec) + opsp = opsp + 1 + if opsp == 16 + return parse_err(@estk_overflw) + fin + opstack[opsp] = op + precstack[opsp] = prec +end +def pop_op + if opsp < 0 + return parse_err(@estk_underflw) + fin + opsp = opsp - 1 + return opstack[opsp + 1] +end +def tos_op + if opsp < 0 + return 0 + fin + return opstack[opsp] +end +def tos_op_prec(tos) + if opsp <= tos + return 100 + fin + return precstack[opsp] +end +// +// Lexical anaylzer +// +def keymatch(chrptr, len) + byte i, keypos + + keypos = 0 + while keywrds[keypos] < len + keypos = keypos + keywrds[keypos] + 2 + loop + while keywrds[keypos] == len + for i = 1 to len + if toupper((chrptr).[i - 1]) <> keywrds[keypos + i] + break + fin + next + if i > len + return keywrds[keypos + keywrds[keypos] + 1] + fin + keypos = keypos + keywrds[keypos] + 2 + loop + return ID_TKN +end +def skipspace + // + // Skip whitespace + // + while ^scanptr and ^scanptr <= ' ' + scanptr = scanptr + 1 + loop + tknptr = scanptr + return !^scanptr or ^scanptr == ';' +end +def scan + // + // Scan for token based on first character + // + if skipspace + if token <> EOF_TKN + token = EOL_TKN + fin + elsif isalpha(^scanptr) + // + // ID, either variable name or reserved word + // + repeat + scanptr = scanptr + 1 + until !isalphanum(^scanptr) + tknlen = scanptr - tknptr// + token = keymatch(tknptr, tknlen) + elsif isnum(^scanptr) + // + // Decimal constant + // + token = INT_TKN + constval = 0 + repeat + constval = constval * 10 + ^scanptr - '0' + scanptr = scanptr + 1 + until !isnum(^scanptr) + elsif ^scanptr == '$' + // + // Hexadecimal constant + // + token = INT_TKN// + constval = 0 + repeat + scanptr = scanptr + 1 + if ^scanptr >= '0' and ^scanptr <= '9' + constval = (constval << 4) + ^scanptr - '0' + elsif ^scanptr >= 'A' and ^scanptr <= 'F' + constval = (constval << 4) + ^scanptr - '7'// 'A'-10 + elsif ^scanptr >= 'a' and ^scanptr <= 'f' + constval = (constval << 4) + ^scanptr - 'W'// 'a'-10 + else + break// + fin + until !^scanptr + elsif ^scanptr == $27 // ' + // + // Character constant + // + token = CHR_TKN + if ^(scanptr + 1) <> $5C // \ + constval = ^(scanptr + 1) + if ^(scanptr + 2) <> $27 // ' + return parse_err(@bad_cnst) + fin + scanptr = scanptr + 3 + else + when ^(scanptr + 2) + is 'n' + constval = $0D; 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 + elsif ^scanptr == '"' + // + // String constant + // + token = STR_TKN + scanptr = scanptr + 1 + constval = scanptr + while ^scanptr and ^scanptr <> '"' + scanptr = scanptr + 1 + loop + if !^scanptr + return parse_err(@bad_cnst) + fin + scanptr = scanptr + 1 + else + // + // Potential two and three character tokens + // + when ^scanptr + is '>' + if ^(scanptr + 1) == '>' + token = SHR_TKN + scanptr = scanptr + 2 + elsif ^(scanptr + 1) == '=' + token = GE_TKN + scanptr = scanptr + 2 + else + token = GT_TKN + scanptr = scanptr + 1 + fin + 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 = scanptr + 1 + 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 = scanptr + 1 + fin + break + is '-' + if ^(scanptr + 1) == '>' + token = PTRB_TKN + scanptr = scanptr + 2 + else + token = SUB_TKN + scanptr = scanptr + 1 + fin + break + is '/' + if ^(scanptr + 1) == '/' + token = EOL_TKN + scanptr = scanptr + 2 + else + token = DIV_TKN + scanptr = scanptr + 1 + fin + break + is '~' + token = COMP_TKN + scanptr = scanptr + 1 + break + is '|' + token = OR_TKN + scanptr = scanptr + 1 + break + otherwise + // + // Simple single character tokens + // + token = ^scanptr | $80 + scanptr = scanptr + 1 + wend + fin + tknlen = scanptr - tknptr + return token +end +def rewind(ptr) + scanptr = ptr +end +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 = scanptr + 1 + scan + else + scanptr = inbuff + if lineno < numlines + cpyln(strlinbuf:[lineno], instr) + lineno = lineno + 1 + if !(lineno & $0F); cout('.'); fin + // cout('>') + // prstr(instr) + // crout + scan + else + ^instr = 0 + ^inbuff = $00 + token = DONE_TKN + fin + fin + return ^instr +end +// +// Parser +// +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_constval(valptr, sizeptr) + byte mod, type + word idptr + + mod = 0 + type = 0 + *valptr = 0 + while !parse_term + when token + is SUB_TKN + mod = mod | 1; break + 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 + loop + when token + is STR_TKN + *valptr = constval + ^sizeptr = tknlen - 1 + type = STR_TYPE + if mod + return parse_err(@bad_op) + fin + break + is CHR_TKN + *valptr = constval + ^sizeptr = 1 + type = BYTE_TYPE + break + is INT_TKN + *valptr = constval + ^sizeptr = 2 + type = WORD_TYPE + break + is ID_TKN + ^sizeptr = 2 + idptr = id_lookup(tknptr, tknlen) + if !idptr + return parse_err(@bad_cnst) + fin + type = idptr->idtype + *valptr = idptr=>idval + if type & VAR_TYPE and !(mod & 8) + return parse_err(@bad_cnst) + fin + break + otherwise + return parse_err(@bad_cnst) + wend + if mod & 1 + *valptr = -*valptr + fin + if mod & 2 + *valptr = ~*valptr + fin + if mod & 4 + *valptr = !*valptr + fin + return type +end +def ispostop + scan + when token + 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_value(rvalue) + byte cparams, deref, type, emit_val + word optos, idptr, value + byte elem_size, elem_type + word elem_offset + + deref = rvalue + optos = opsp + type = 0 + emit_val = false + value = 0 + + // + // Parse pre-ops + // + while !parse_term + when token + is ADD_TKN + break + is BPTR_TKN + if deref + push_op(token, 0) + else + type = type | BPTR_TYPE + deref = deref + 1 + fin + break + is WPTR_TKN + if deref + push_op(token, 0) + else + type = type | WPTR_TYPE + deref = deref + 1 + fin + break + is AT_TKN + deref = deref - 1; break + is SUB_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 + 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 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 + // + while ispostop + when token + is OPEN_BRACKET_TKN + // + // Array + // + if !emit_val + if type & ADDR_TYPE + if type & LOCAL_TYPE + emit_localaddr(value) + else + emit_globaladdr(value) + fin + elsif type & CONST_TYPE + emit_const(value) + fin + emit_val = true + fin // !emit_val + if type & PTR_TYPE + emit_lw + fin + if !parse_expr + return 0 + fin + if token <> CLOSE_BRACKET_TKN + return parse_err(@no_close_bracket) + fin + if type & WORD_TYPE + type = WPTR_TYPE + emit_indexword + else + type = BPTR_TYPE + emit_indexbyte + fin + break + is PTRB_TKN + is PTRW_TKN + if !emit_val + if type & FUNC_TYPE + emit_call(value, type) + elsif type & VAR_TYPE + if type & LOCAL_TYPE + if type & BYTE_TYPE + emit_llb(value + elem_offset) + else + emit_llw(value + elem_offset) + fin + else + if type & BYTE_TYPE + emit_lab(value, elem_offset, type) + else + emit_law(value, elem_offset, type) + fin + fin + else + if type & BPTR_TYPE + emit_lb + else + emit_lw + fin + fin + emit_val = 1; + fin + type = type & ~(VAR_TYPE | ADDR_TYPE) + type = type | WORD_TYPE + if token == PTRB_TKN + token = DOT_TKN + else + token = COLON_TKN + fin + // + // Fall through + // + is DOT_TKN + is COLON_TKN + // + // Dot and Colon + // + if token == DOT_TKN + elem_type = BPTR_TYPE + else + elem_type = WPTR_TYPE + fin + if parse_constval(@elem_offset, @elem_size) + // + // Constant structure offset + // + if !emit_val + if type & VAR_TYPE + if type & LOCAL_TYPE + emit_localaddr(value + elem_offset) + else + // emit_globaladdr(value + elem_offset) + emit_globaladdr(value) + emit_const(elem_offset) + emit_binaryop(ADD_TKN) + fin + elsif type & CONST_TYPE + value = value + elem_offset + emit_const(value) + else // FUNC_TYPE + emit_globaladdr(value) + emit_const(elem_offset) + emit_binaryop(ADD_TKN) + fin + emit_val = true + else + if elem_offset <> 0 + emit_const(elem_offset) + emit_binaryop(ADD_TKN) + fin + fin // !emit_val + elsif token == OPEN_BRACKET_TKN + // + // Array of arrays + // + if !emit_val + if type & ADDR_TYPE + if type & LOCAL_TYPE + emit_localaddr(value) + else + emit_globaladdr(value) + fin + elsif type & CONST_TYPE + emit_const(value) + fin + emit_val = true + fin // !emit_val + while parse_expr + if token <> COMMA_TKN + break + fin + emit_indexword + emit_lw + loop + if token <> CLOSE_BRACKET_TKN + return parse_err(@no_close_bracket) + fin + if elem_type & WPTR_TYPE + emit_indexword + else + emit_indexbyte + fin + else + return parse_err(@bad_offset) + fin + type = elem_type + break + is OPEN_PAREN_TKN + // + // Function call + // + if emit_val and type & VAR_TYPE + 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 type & FUNC_CONST_TYPE + emit_call(value, type) + else + if !emit_val + if type & VAR_TYPE + if type & LOCAL_TYPE + emit_llw(value + elem_offset) + else + emit_law(value, elem_offset, type) + fin + elsif type & PTR_TYPE + emit_lw + fin + else + if cparams + emit_pull + fin + fin + emit_ical + fin + emit_val = true + type = WORD_TYPE + wend + loop + if emit_val + if rvalue + if deref and type & PTR_TYPE + if type & BPTR_TYPE + emit_lb + else + emit_lw + fin + fin + fin + else // emit_val + if type & CONST_TYPE + emit_const(value) + elsif deref + if type & FUNC_TYPE + emit_call(value, 0) + elsif type & VAR_TYPE + if type & LOCAL_TYPE + if type & BYTE_TYPE + emit_llb(value + elem_offset) + else + emit_llw(value + elem_offset) + fin + else + if type & BYTE_TYPE + emit_lab(value, elem_offset) + else + emit_law(value, elem_offset) + fin + fin + elsif type & PTR_TYPE + if type & BPTR_TYPE + emit_lb + else + emit_lw + fin + fin + else + if type & LOCAL_TYPE + emit_localaddr(value + elem_offset) + else + emit_globaladdr(value, elem_offset) + fin + fin + fin // emit_val + while optos < opsp + if !emit_unaryop(pop_op) + return parse_err(@bad_op) + fin + loop + return type +end +def parse_constexpr(valptr, sizeptr) + byte type, size1, size2 + word val1, val2 + + type = parse_constval(@val1, @size1) + if !type; return 0; fin + size2 = 0 + when scan + is ADD_TKN + type = parse_constval(@val2, @size2) + if !type; return 0; fin + *valptr = val1 + val2 + break + is SUB_TKN + type = parse_constval(@val2, @size2) + if !type; return 0; fin + *valptr = val1 - val2 + break + is MUL_TKN + type = parse_constval(@val2, @size2) + if !type; return 0; fin + *valptr = val1 * val2 + break + is DIV_TKN + type = parse_constval(@val2, @size2) + if !type; return 0; fin + *valptr = val1 / val2 + break + is MOD_TKN + type = parse_constval(@val2, @size2) + if !type; return 0; fin + *valptr = val1 % val2 + break + is AND_TKN + type = parse_constval(@val2, @size2) + if !type; return 0; fin + *valptr = val1 & val2 + break + is OR_TKN + type = parse_constval(@val2, @size2) + if !type; return 0; fin + *valptr = val1 | val2 + break + is EOR_TKN + type = parse_constval(@val2, @size2) + if !type; return 0; fin + *valptr = val1 ^ val2 + break + otherwise + *valptr = val1 + wend + if size1 > size2 + ^sizeptr = size1 + else + ^sizeptr = size2 + fin + return type +end +def parse_expr + byte prevmatch, matchop, i + word optos + + matchop = 0 + optos = opsp + repeat + prevmatch = matchop + matchop = 0 + if parse_value(1) + matchop = 1 + for i = 0 to bops_tblsz + if token == bops_tbl[i] + matchop = 2 + if bops_prec[i] >= tos_op_prec(optos) + if !emit_binaryop(pop_op) + return parse_err(@bad_op) + fin + fin + push_op(token, bops_prec[i]) + break + fin + next + fin + until matchop <> 2 + if matchop == 0 and prevmatch == 2 + return parse_err(@missing_op) + fin + while optos < opsp + if !emit_binaryop(pop_op) + return parse_err(@bad_op) + fin + loop + return matchop or prevmatch +end +def parse_stmnt + byte type, elem_type, elem_size, i + word elem_offset, tag_prevbrk, 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) + emit_codetag(tag_else) + if !parse_expr; return 0; fin + tag_else = ctag_new + emit_brfls(tag_else) + until false + if token == ELSE_TKN + emit_branch(tag_endif) + emit_codetag(tag_else) + scan + while parse_stmnt + nextln + loop + emit_codetag(tag_endif) + else + emit_codetag(tag_else) + emit_codetag(tag_endif) + fin + if token <> FIN_TKN; return parse_err(@no_fin); fin + break + is WHILE_TKN + tag_while = ctag_new + tag_wend = ctag_new + tag_prevbrk = break_tag + break_tag = tag_wend + emit_codetag(tag_while) + if !parse_expr; return 0; fin + emit_brfls(tag_wend) + while parse_stmnt + nextln + loop + if token <> LOOP_TKN; return parse_err(@no_loop); fin + emit_branch(tag_while) + emit_codetag(tag_wend) + break_tag = tag_prevbrk + break + is REPEAT_TKN + tag_repeat = ctag_new + tag_prevbrk = break_tag + break_tag = ctag_new + emit_codetag(tag_repeat) + scan + while parse_stmnt + nextln + loop + if token <> UNTIL_TKN; return parse_err(@no_until); fin + if !parse_expr; return 0; fin + emit_brfls(tag_repeat) + emit_codetag(break_tag) + break_tag = tag_prevbrk + break + is FOR_TKN + stack_loop = stack_loop + 1 + tag_for = ctag_new + tag_prevbrk = break_tag + break_tag = ctag_new + if scan <> ID_TKN; return parse_err(@bad_stmnt); fin + idptr = id_lookup(tknptr, tknlen) + if idptr + type = idptr->idtype + addr = idptr=>idval + else + return false + fin + if scan <> SET_TKN; return parse_err(@bad_stmnt); fin + if !parse_expr; return parse_err(@bad_stmnt); fin + emit_codetag(tag_for) + if type & LOCAL_TYPE + if type & BYTE_TYPE + emit_dlb(addr) + else + emit_dlw(addr) + fin + else + if type & BYTE_TYPE + emit_dab(addr) + else + emit_daw(addr) + fin + fin + if token == TO_TKN + stepdir = 1 + elsif token == DOWNTO_TKN + stepdir = -1 + else + return parse_err(@bad_stmnt) + fin + if !parse_expr; return parse_err(@bad_stmnt); fin + if stepdir > 0 + emit_brgt(break_tag) + else + emit_brlt(break_tag) + fin + if token == STEP_TKN + if !parse_expr; return parse_err(@bad_stmnt); fin + if stepdir > 0 + emit_binaryop(ADD_TKN) + else + emit_binaryop(SUB_TKN) + fin + else + if stepdir > 0 + emit_unaryop(INC_TKN) + else + emit_unaryop(DEC_TKN) + fin + fin + while parse_stmnt + nextln + loop + if token <> NEXT_TKN; return parse_err(@bad_stmnt); fin + emit_branch(tag_for) + emit_codetag(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 + if token == OF_TKN + if !parse_expr; return parse_err(@bad_stmnt); fin + emit_brne(tag_choice) + emit_codetag(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 + emit_codetag(tag_choice) + tag_choice = ctag_new + elsif token == DEFAULT_TKN + emit_codetag(tag_of) + tag_of = 0 + scan + while parse_stmnt + nextln + loop + if token <> ENDCASE_TKN; return parse_err(@bad_stmnt); fin + else + return parse_err(@bad_stmnt) + fin + loop + if (tag_of) + emit_codetag(tag_of) + fin + emit_codetag(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 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 + is COMMENT_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_constval(@elem_offset, @elem_size) + 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 type & BYTE_TYPE + emit_slb(addr + elem_offset) + else + emit_slw(addr + elem_offset) + fin + else + if type & BYTE_TYPE + emit_sab(addr, elem_offset) + else + emit_saw(addr, elem_offset) + fin + fin + break + fin + elsif type & FUNC_TYPE + if scan == EOL_TKN + emit_call(addr, 0) + 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 + else + if type & BPTR_TYPE + emit_lb + elsif type & WPTR_TYPE + emit_lw + fin + emit_drop + fin + else + return parse_err(@bad_syntax) + fin + wend + if scan <> EOL_TKN + return parse_err(@bad_syntax) + fin + return true +end +def parse_var(type) + byte consttype, constsize, idlen + word idptr, constval, arraysize, size + + idlen = 0 + size = 1 + if scan == ID_TKN + idptr = tknptr + idlen = tknlen + if scan == OPEN_BRACKET_TKN + size = 0 + parse_constexpr(@size, @constsize) + if token <> CLOSE_BRACKET_TKN + return parse_err(@no_close_bracket) + fin + scan + fin + fin + if 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 + fin + scan + fin + if type == WORD_TYPE + size = size * 2 + fin + if token == SET_TKN + if infunc + return parse_err(@no_local_init) + fin + if idlen + iddata_add(idptr, idlen, type, 0) + fin + consttype = parse_constexpr(@constval, @constsize) + if consttype + arraysize = emit_data(type, consttype, constval, constsize) + while token == COMMA_TKN + consttype = parse_constexpr(@constval, @constsize) + if consttype + arraysize = arraysize + emit_data(type, consttype, constval, constsize) + else + return parse_err(@bad_decl) + fin + loop + if token <> EOL_TKN + return parse_err(@no_close_bracket) + fin + iddata_size(PTR_TYPE, size, arraysize)// + else + return parse_err(@bad_decl) + fin + elsif idlen + if infunc + idlocal_add(idptr, idlen, type, size) + else + iddata_add(idptr, idlen, type, size) + fin + fin + return true +end +def parse_vars + byte idlen, type, size + word value, idptr + + when token + is CONST_TKN + if scan <> ID_TKN + return parse_err(@bad_cnst) + fin + idptr = tknptr// + idlen = tknlen + if scan <> SET_TKN + return parse_err(@bad_cnst) + fin + if !parse_constexpr(@value, @size) + return parse_err(@bad_cnst) + fin + idconst_add(idptr, idlen, value) + 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 + is COMMENT_TKN + return true + otherwise + return false + wend + return true +end +def parse_defs + byte cfnparms + word func_tag, idptr + + if token == DEF_TKN + if scan <> ID_TKN; return parse_err(@bad_decl); fin + cfnparms = 0 + infunc = true + idptr = idglobal_lookup(tknptr, tknlen) + if idptr + func_tag = (idptr):idval + else + func_tag = ctag_new + idfunc_add(tknptr, tknlen, func_tag) + fin + emit_codetag(func_tag) + retfunc_tag = ctag_new + idlocal_init + if scan == OPEN_PAREN_TKN + repeat + if scan == ID_TKN + cfnparms = cfnparms + 1 + idlocal_add(tknptr, tknlen, WORD_TYPE, 2) + scan + fin + until token <> COMMA_TKN + if token <> CLOSE_PAREN_TKN + return parse_err(@bad_decl) + fin + scan + fin + while parse_vars + nextln + loop + emit_enter(cfnparms) + prevstmnt = 0 + while parse_stmnt + nextln + loop + infunc = false + if token <> END_TKN; return parse_err(@bad_syntax); fin + if scan <> EOL_TKN and token <> COMMENT_TKN; return parse_err(@bad_syntax); fin + if prevstmnt <> RETURN_TKN + emit_const(0) + emit_leave + fin + return true + elsif token == EOL_TKN or token == COMMENT_TKN + return true + fin + return false +end +def parse_module + entrypoint = 0 + idglobal_init + idlocal_init + if nextln + while parse_vars + nextln + loop + while parse_defs + nextln + loop + framesize = 0 + if token <> DONE_TKN + emit_start + prevstmnt = 0 + while parse_stmnt + nextln + loop + if token <> DONE_TKN; parse_err(@no_done); fin + if prevstmnt <> RETURN_TKN + emit_const(0) + emit_leave + fin + fin + dumpsym(idglobal_tbl, globals) + prstr(@entrypt_str) + prword(entrypoint) + crout + keyin() + return true + fin + return false +end +// +// Init editor +// +if !(^machid & $80) + flags = uppercase | shiftlock + keyin = @keyin2 +else + keyin = @keyin2e +fin +inittxtbuf +if argbuff + strcpy(@argbuff, @txtfile) + prstr(@txtfile) + numlines = 0 + readtxt(@txtfile) +fin +curschr = '+' +flags = flags | insmode +drawscrn(scrntop, scrnleft) +curson +editmode +done