diff --git a/src/libsrc/longjmp.pla b/src/libsrc/longjmp.pla index 462e394..1f797c8 100644 --- a/src/libsrc/longjmp.pla +++ b/src/libsrc/longjmp.pla @@ -12,20 +12,18 @@ export asm setjmp(env) STX ESP TSX STX TMPL + LDY TMPL +- LDA $0100,Y + STA (SRC),Y + INY + BNE - + INC SRC+1 LDX #ESTK - LDY #$00 - LDA $00,X STA (SRC),Y INY INX BNE - -- LDA $0100,X - STA (SRC),Y - INY - BNE + - INC SRC+1 -+ INX - BNE - TXA LDX ESP STA ESTKL,X @@ -42,8 +40,9 @@ export asm longjmp(env, retval) STA SRC+1 LDA ESTKL+1,X STA DST - LDA ESTKH+1,X - STA DST+1 + LDY ESTKH+1,X + INY + STY DST+1 LDX #ESTK LDY #$00 - LDA (DST),Y @@ -51,15 +50,14 @@ export asm longjmp(env, retval) INY INX BNE - -- LDA (DST),Y - STA $0100,X - INY - BNE + - INC DST+1 -+ INX - BNE - - LDX TMP + DEC DST+1 + LDX TMPL TXS + LDY TMPL +- LDA (DST),Y + STA $0100,Y + INY + BNE - LDX ESP LDA SRC STA ESTKL,X diff --git a/src/makefile b/src/makefile index 997e798..428f1dc 100755 --- a/src/makefile +++ b/src/makefile @@ -50,6 +50,7 @@ PROFILE = PROFILE\#FE1000 MEMMGR = MEMMGR\#FE1000 MEMTEST = MEMTEST\#FE1000 FIBER = FIBER\#FE1000 +LONGJMP = LONGJMP\#FE1000 PLASM = plasm INCS = toolsrc/plasm.h toolsrc/tokens.h toolsrc/symbols.h toolsrc/lex.h toolsrc/parse.h toolsrc/codegen.h OBJS = toolsrc/plasm.c toolsrc/parse.c toolsrc/lex.c toolsrc/codegen.c @@ -69,7 +70,7 @@ TXTTYPE = .TXT #SYSTYPE = \#FF2000 #TXTTYPE = \#040000 -all: $(PLASM) $(PLVM) $(PLVM01) $(PLVM02) $(PLVM802) $(PLVM03) $(CMD) $(ARGS) $(MEMMGR) $(MEMTEST) $(FIBER) $(ED) $(MON) $(ROD) $(SIEVE) $(UTHERNET2) $(UTHERNET) $(ETHERIP) $(INET) $(DHCP) $(HTTPD) $(ROGUE) $(ROGUEMAP) $(ROGUECOMBAT) $(ROGUEIO) $(HGR1) $(TONE) $(DGR) $(DGRTEST) $(FILEIO) $(CONIO) $(PORTIO) $(SPIPORT) $(SDFAT) $(FATCAT) $(FATGET) $(FATPUT) $(FATWDSK) $(FATRDSK) $(SANE) $(FPSTR) $(FPU) $(SANITY) $(RPNCALC) +all: $(PLASM) $(PLVM) $(PLVM01) $(PLVM02) $(PLVM802) $(PLVM03) $(CMD) $(ARGS) $(MEMMGR) $(MEMTEST) $(FIBER) $(LONGJMP) $(ED) $(MON) $(ROD) $(SIEVE) $(UTHERNET2) $(UTHERNET) $(ETHERIP) $(INET) $(DHCP) $(HTTPD) $(ROGUE) $(ROGUEMAP) $(ROGUECOMBAT) $(ROGUEIO) $(HGR1) $(TONE) $(DGR) $(DGRTEST) $(FILEIO) $(CONIO) $(PORTIO) $(SPIPORT) $(SDFAT) $(FATCAT) $(FATGET) $(FATPUT) $(FATWDSK) $(FATRDSK) $(SANE) $(FPSTR) $(FPU) $(SANITY) $(RPNCALC) clean: -rm *FE1000 *FF2000 $(PLASM) $(PLVM) $(PLVM01) $(PLVM02) $(PLVM03) @@ -145,6 +146,10 @@ $(FIBER): libsrc/fiber.pla $(PLVM02) $(PLASM) ./$(PLASM) -AMOW < libsrc/fiber.pla > libsrc/fiber.a acme --setpc 4094 -o $(FIBER) libsrc/fiber.a +$(LONGJMP): libsrc/longjmp.pla $(PLVM02) $(PLASM) + ./$(PLASM) -AMOW < libsrc/longjmp.pla > libsrc/longjmp.a + acme --setpc 4094 -o $(LONGJMP) libsrc/longjmp.a + $(MON): samplesrc/mon.pla $(PLVM02) $(PLASM) ./$(PLASM) -AMOW < samplesrc/mon.pla > samplesrc/mon.a acme --setpc 4094 -o $(MON) samplesrc/mon.a diff --git a/src/toolsrc/parse.c b/src/toolsrc/parse.c index b24e0a6..d1986c3 100755 --- a/src/toolsrc/parse.c +++ b/src/toolsrc/parse.c @@ -347,7 +347,7 @@ t_opseq *parse_value(t_opseq *codeseq, int rvalue, int *stackdepth) /* * Parse pre operators. */ - while (scan) + while (scan()) { if (scantoken == ADD_TOKEN) { @@ -364,8 +364,7 @@ t_opseq *parse_value(t_opseq *codeseq, int rvalue, int *stackdepth) { deref++; if (!type) - //type |= scantoken == BPTR_TOKEN ? BPTR_TYPE : WPTR_TYPE; - type = scantoken == BPTR_TOKEN ? BPTR_TYPE : WPTR_TYPE; + type |= scantoken == BPTR_TOKEN ? BPTR_TYPE : WPTR_TYPE; else if (scantoken == BPTR_TOKEN) parse_error("Byte value used as pointer"); } diff --git a/src/toolsrc/swyftcode.pla b/src/toolsrc/swyftcode.pla deleted file mode 100644 index 285c4af..0000000 --- a/src/toolsrc/swyftcode.pla +++ /dev/null @@ -1,4207 +0,0 @@ -// -// 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 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 = $6800 -const strheasz = $4000 -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 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 ][ SWYFTCODE VERSION 00.11 " -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 -// -// Compiler variables -// -// -// Tokens -// -const ID_TKN = $D6 // V -const CHR_TKN = $C3 // C -const INT_TKN = $C9 // I -const HEX_TKN = $9D -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 LOGIC_NOT_TKN = $FE // ~ -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 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 -// -// 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 entrypt_str[] = "START: " -byte bytes_compiled_str[] = "\nBYTES COMPILED: " -//byte comp_ok_msg[] = "COMPILATION COMPLETE" -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_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 $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 -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 - 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 - LDA ESTKL,X - 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 - LDY #$00 - LDA ESTKL,X - STA SRCL - LDA ESTKH,X - STA SRCH - LDA (SRC),Y - STA TMP - BEQ ++ - BIT ROMEN -- INY - LDA (SRC),Y - BIT $BF98 - BMI + - JSR TOUPR -+ 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 - - TAX - LDX ESP - 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 -TOUPR AND #$7F - CMP #'z'+1 - BCS + - CMP #'a' - BCC + - 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 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 - LDY #$00 - LDA ESTKL,X - CMP #'_' - BEQ ISALTRU - CMP #'A' - BCC ISALRET - AND #$DF - 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 - 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 #'_' - BEQ ISANTRU - CMP #'0' - BCC ISANRET - CMP #'9'+1 - BCC ISANTRU - CMP #'A' - BCC ISANRET - AND #$DF - 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[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 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 -// -// Tokenizer -// -def keymatch(tknptr, tknlen) - 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 strtotkn(str, strlen) - word charptr, tknptr, strptr - byte[128] tknize - - // - // Skip whitespace - // - charptr = skipspace(str) - tknptr = @tknize.1 - // - // Save indentation amount - // - ^tknptr = charptr - str - // - // Beginning of token. - // - strptr = charptr - while (charptr - str) < strlen - // - // Scan for token based on first character - // - tknlen = 1 - if isalpha(^charptr) - // - // ID, either variable name or reserved word - // - repeat - charptr = charptr + 1 - until !isalphanum(^charptr) - tknlen = charptr - strptr - token = keymatch(strptr, tknlen) - if token == ID_TKN - // - // Copy ID string to tokenized stream - // - ^(tknptr + 1) = tknlen - while strptr < charptr - ^(tknptr = ^strptr - strptr = strptr + 1 - loop - fin - elsif isnum(scanchr) - // - // Decimal constant - // - constval = 0 - repeat - constval = constval * 10 + ^scanptr - '0' - scanptr = scanptr + 1 - until !isnum(^scanptr) - // - // Copy constant value to tokenized stream - // - token = INT_TKN - *(tknptr + 1) = constval - tknlen = 3 - else - // - // Potential multiple character tokens - // - when charptr - is '/' - if ^(charptr + 1) == '/' - token = COMMENT_TKN - charptr = charptr + 2 - // - // Copy comment string to tokenized stream - // - while (charptr - strptr) < strlen - ^(tknptr + tknlen + 2) = ^charptr - strptr = strptr + 1 - tknlen = tknlen + 1 - loop - ^(tknptr + 1) = tknlen - else - token = DIV_TKN - fin - break - is '=' - if ^(charptr + 1) == '=' - token = EQ_TKN - charptr = charptr + 2 - elsif ^(charptr + 1) == '>' - token = PTRW_TKN - charptr = charptr + 2 - else - token = SET_TKN - charptr = charptr + 1 - fin - break - is '-' - if ^(charptr + 1) == '>' - token = PTRB_TKN - charptr = charptr + 2 - else - token = SUB_TKN - charptr = charptr + 1 - fin - break - is '>' - if ^(charptr + 1) == '>' - token = SHR_TKN - charptr = charptr + 2 - elsif ^(charptr + 1) == '=' - token = GE_TKN - charptr = charptr + 2 - else - token = GT_TKN - charptr = charptr + 1 - fin - break - is '<' - if ^(charptr + 1) == '<' - token = SHL_TKN - charptr = charptr + 2 - elsif ^(charptr + 1) == '=' - token = LE_TKN - charptr = charptr + 2 - elsif ^(charptr + 1) == '>' - token = NE_TKN - charptr = charptr + 2 - else - token = LT_TKN - charptr = charptr + 1 - fin - break - is '$' - // - // Hexadecimal constant - // - token = HEX_TKN - tknlen = 3 - constval = 0 - repeat - charptr = charptr + 1 - if ^charptr >= '0' and ^charptr <= '9' - constval = (constval << 4) + ^charptr - '0' - elsif ^charptr >= 'A' and ^charptr <= 'F' - constval = (constval << 4) + ^charptr - '7'// 'A'-10 - elsif ^charptr >= 'a' and ^charptr <= 'f' - constval = (constval << 4) + ^charptr - 'W'// 'a'-10 - else - *(tknptr + 1) = constval - break - fin - until !^charptr - *(tknptr + 1) = constval - break - is $27 // ' - // - // Character constant - // - token = CHR_TKN - if ^(charptr + 1) <> $5C // \ - constval = ^(charptr + 1) - if ^(charptr + 2) <> $27 // ' - return parse_err(@bad_cnst) - fin - charptr = charptr + 3 - else - when ^(charptr + 2) - is 'n' - constval = $0D; break - is 'r' - constval = $0A; break - is 't' - constval = $09; break - otherwise - constval = ^(charptr + 2) - wend - if ^(charptr + 3) <> $27 // ' - return parse_err(@bad_cnst) - fin - charptr = charptr + 4 - fin - ^(tknptr + 1 = constval - tknlen = 2 - break - is '"' - // - // String constant - // - token = STR_TKN - charptr = charptr + 1 - constval = scanptr - while ^charptr and ^charptr <> '"' - charptr = charptr + 1 - loop - if !^charptr - return parse_err(@bad_cnst) - fin - charptr = charptr + 1 - break - is 0 - is ';' - if token <> EOF_TKN - token = EOL_TKN - fin - break - otherwise - // - // Simple single character tokens - // - token = scanchr | $80 - charptr = charptr + 1 - wend - fin - ^tknptr = token - tknptr = tknptr + tknlen - loop - return token -end -def tkntostr(tknptr, strptr) - byte strlen - - return strlen -end -// -// String utilities -// -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 strcpy(dststr, srcstr) - 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 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 strptr, scrnptr - - 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 -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 - byte key - repeat - cursflash - until ^keyboard >= 128 - key = ^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 = keyctrlo - 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 - if key == keyctrln - key = $DB // [ - elsif key == keyctrlp - key = $DF // _ - elsif key == keyctrlb - key = $FC // | - elsif key == keyctrly - key = $FE // ~ - 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(@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 = 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(@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 = 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(undoline, @editstr) - memcpy(@editstr[curscol + 1], @editstr[curscol + 2], editstr - curscol) - editstr = editstr - 1 - 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 - 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) - curscol = 0 - cursx = 0 - scrnleft = 0 - 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(TRUE) - 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(@path, optpath) - 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(clearscr) - 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) - word updtptr, nextptr - - ctag = ctag & MASK_CTAG // Better be a ctag! - if ctag_tbl:[ctag] & IS_RESOLVED; return parse_err(@dup_id); 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) - ^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_op(op) - lastop = op - return emit_byte(op) -end -def emit_addr(tag) - 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) - 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) - 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 & 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) - 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(offset) - emit_op($64) - return emit_byte(offset) -end -def emit_llw(offset) - emit_op($66) - return emit_byte(offset) -end -def emit_lab(tag, offset) - if tag & IS_CTAG and offset; return parse_err(@no_ctag_offst); fin - emit_op($68) - return emit_addr(tag+offset) -end -def emit_law(tag, offset) - if tag & IS_CTAG and offset; return parse_err(@no_ctag_offst); fin - emit_op($6A) - return emit_addr(tag+offset) -end -def emit_sb - return emit_op($70) -end -def emit_sw - return emit_op($72) -end -def emit_slb(offset) - emit_op($74) - return emit_byte(offset) -end -def emit_slw(offset) - emit_op($76) - return emit_byte(offset) -end -def emit_dlb(offset) - emit_op($6C) - return emit_byte(offset) -end -def emit_dlw(offset) - emit_op($6E) - return emit_byte(offset) -end -def emit_sab(tag, offset) - if tag & IS_CTAG and offset; return parse_err(@no_ctag_offst); fin - emit_op($78) - return emit_addr(tag+offset) -end -def emit_saw(tag, offset) - if tag & IS_CTAG and offset; return parse_err(@no_ctag_offst); fin - emit_op($7A) - return emit_addr(tag+offset) -end -def emit_dab(tag, offset) - if tag & IS_CTAG and offset; return parse_err(@no_ctag_offst); fin - emit_op($7C) - return emit_addr(tag+offset) -end -def emit_daw(tag, offset) - if tag & IS_CTAG and offset; return parse_err(@no_ctag_offst); fin - emit_op($7E) - return emit_addr(tag+offset) -end -def emit_call(tag) - emit_op($54) - return emit_addr(tag) -end -def emit_ical - return emit_op($56) -end -def emit_push - emit_op($34) -end -def emit_pull - emit_op($36) -end -def emit_localaddr(offset) - emit_op($28) - return emit_byte(offset) -end -def emit_globaladdr(tag, offset) - if tag & IS_CTAG and offset; return parse_err(@no_ctag_offst); fin - emit_op($26) - return emit_addr(tag+offset) -end -def emit_indexbyte - return emit_op($02) -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_reladdr(tag) -end -def emit_brfls(tag) - emit_op($4C) - return emit_reladdr(tag) -end -def emit_brgt(tag) - emit_op($38) - return emit_reladdr(tag) -end -def emit_brlt(tag) - emit_op($3A) - return emit_reladdr(tag) -end -def emit_brne(tag) - emit_op($3E) - return emit_reladdr(tag) -end -def emit_branch(tag) - emit_op($50) - return emit_reladdr(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 -// -// 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_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 = 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 + 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 = 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 - 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 - 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 - 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 = scanptr + 1 - 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 = scanptr + 1 - until !isnum(^scanptr) - else - // - // Potential multiple character tokens - // - when scanchr - is '/' - if ^(scanptr + 1) == '/' - token = EOL_TKN - ^scanptr = $00 - else - token = DIV_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 = 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 '$' - // - // 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 - 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 - scanptr = scanptr + 1 - constval = scanptr - while ^scanptr and ^scanptr <> '"' - scanptr = scanptr + 1 - loop - if !^scanptr - return parse_err(@bad_cnst) - fin - scanptr = scanptr + 1 - break - is 0 - is ';' - if token <> EOF_TKN - token = EOL_TKN - fin - break - otherwise - // - // Simple single character tokens - // - token = scanchr | $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 = 0 - token = DONE_TKN - fin - fin - return token -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, ctag - - mod = 0 - type = 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 - if type & ADDR_TYPE - if mod <> 8; return parse_err(@bad_cnst); fin - type = CONSTADDR_TYPE - fin - *valptr = idptr=>idval - 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 - 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_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 - elem_offset = 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, 0) - 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) - 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 - else - if type & BPTR_TYPE - emit_lb - else - emit_lw - fin - fin - emit_val = 1; - else - if type & BYTE_TYPE - emit_lab(value, elem_offset) - else - emit_law(value, elem_offset) - fin - 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 elem_type & BPTR_TYPE - elem_type = (type & ~VAR_TYPE) | BYTE_TYPE - else - elem_type = (type & ~VAR_TYPE) | WORD_TYPE - fin - elsif type & CONST_TYPE - value = value + elem_offset - emit_const(value) - elem_offset = 0 - emit_val = TRUE - else // FUNC_TYPE - emit_globaladdr(value, 0) - emit_const(elem_offset) - emit_binaryop(ADD_TKN) - elem_offset = 0 - emit_val = TRUE - fin - else - if elem_offset <> 0 - emit_const(elem_offset) - emit_binaryop(ADD_TKN) - elem_offset = 0 - 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 + elem_offset) - else - emit_globaladdr(value, elem_offset) - fin - elsif type & CONST_TYPE - emit_const(value + elem_offset) - fin - elem_offset = 0 - 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) - else - if !emit_val - if type & VAR_TYPE - if type & LOCAL_TYPE - emit_llw(value + elem_offset) - else - emit_law(value, elem_offset) - 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) - 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 - if !type - type = WORD_TYPE - fin - 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_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 - if token == 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 - elsif token == 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 - else - return parse_err(@bad_stmnt) - fin - 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_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 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 - 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 - 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 == 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 - - 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 - - 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 - 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 - framesize = 0 - entrypoint = codeptr - emit_enter(0) - prevstmnt = 0 - if token <> DONE_TKN - while parse_stmnt - nextln - loop - fin - 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, 24, 0) -^$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