{{ ''*************************************** ''* Forth v0.0 * ''* Author: Eric Overheu * ''* Copyright (c) 2017 Eric Overheu * ''* See end of file for terms of use. * ''*************************************** }} CON _clkmode = xtal1 + pll16x _xinfreq = 5_000_000 PUB Start waitcnt(cnt + clkfreq) core_start := @forth_start cognew(@vm_entry,@core_start) CON { ************************* SYSTEMKONSTANTEN **************************** } PRIM = $8000 DAT { ************************* SYSTEMVARIABLEN ***************************** } core_start long 0 long 0 long 0 long 0 long 0 long 0 long 0 long 0 long 0 long 0 DAT { ************************* FORTH-KERNEL ******************************** } vm org 0 { *** INITIALISIERUNG *** } vm_entry mov REG_A,par rdlong IP,REG_A mov RP,retstk0 jmp #doNEXT { *** PRIMÄRE FUNKTIONEN *** } ' *** System *** _CNT mov REG_A,cnt jmp #pushnext _WAIT mov REG_A,cnt add REG_A,tos waitcnt REG_A,tos jmp #DROP _IP mov REG_A,IP jmp #pushnext ' *** Stackmanipulationen *** RPOP call #rspop call #dspush jmp #doNEXT PUSHR call #dspop call #rspush jmp #doNEXT drop3 call #dspop drop2 call #dspop DROP call #dspop jmp #doNEXT SWAP mov REG_A,tos+1 mov tos+1,tos mov tos,REG_A jmp #doNEXT QDUP tjz tos,#doNEXT DUP mov REG_A,tos pushnext call #dspush jmp #doNEXT OVER mov REG_A,tos+1 jmp #pushnext ROT mov REG_A,tos+2 mov tos+2,tos+1 mov tos+1,tos mov tos,REG_A jmp #doNEXT LITW rdword REG_A,IP add IP,#2 jmp #pushnext LITL rdword REG_A,IP add IP,#2 shl REG_A,#16 rdword REG_B,IP add IP,#2 or REG_A,REG_B jmp #pushnext LIT6B shr REG_A,#9 and REG_A,#$3F jmp #pushnext LITS rdbyte REG_B,IP mov REG_A,IP add IP,REG_B add IP,#2 andn IP,#1 jmp #pushnext _DS mov REG_A,depth jmp #pushnext ' *** Wortdefinitionen *** _DATA mov REG_A,IP call #dspush jmp #EXIT ' *** Logische Funktionen *** INVERT add tos,#1 jmp #NEGATE _AND and tos+1,tos jmp #DROP _ANDN andn tos+1,tos jmp #DROP _OR or tos+1,tos jmp #DROP _XOR xor tos+1,tos jmp #DROP _SHL shl tos+1,tos jmp #DROP _SHR shr tos+1,tos jmp #DROP _ROL rol tos+1,tos jmp #DROP _ROR ror tos+1,tos jmp #DROP TONIB and tos,#$0F TOBYTE and tos,#$FF jmp #doNEXT ' *** Vergleichsfunktionen *** EQ cmp tos+1,tos wz,wc jmp #ZEQ1 ZEQ mov tos+1,tos cmp tos,#0 wz,wc ZEQ1 muxz tos+1,_32b jmp #DROP NEQ cmp tos+1,tos wz,wc muxnz tos+1,_32b jmp #DROP GT cmps tos,tos+1 wz,wc jmp #LT1 LT cmps tos+1,tos wz,wc LT1 muxc tos+1,_32b jmp #DROP ' *** Integer Arithmetik *** MINUS neg tos,tos PLUS add tos+1,tos wc jmp #DROP DEC test $,#1 wc INC sumc tos,#1 jmp #doNEXT NEGATE neg tos,tos jmp #doNEXT UMSTAR abs tos+1,tos+1 wc muxc REG_A,#1 abs tos,tos wc if_c xor REG_A,#1 mov REG_B,#0 mov REG_C,#32 shr tos+1,#1 wc :loop if_c add REG_B,tos wc rcr REG_B,#1 wc rcr tos+1,#1 wc djnz REG_C,#:loop jmp #DROP USLASHMOD mov REG_B,#0 abs tos+1,tos+1 wc muxc REG_C,#1 abs tos,tos wc,wz if_z mov tos+1,#0 if_z jmp #:end if_c xor REG_C,#1 mov REG_A,#33 :loop cmpsub REG_B,tos wc rcl tos+1,#1 wc rcl REG_B,#1 djnz REG_A,#:loop shr REG_B,#1 test REG_C,#1 wz :end mov tos,tos+1 mov tos+1,REG_B jmp #doNEXT _ABS abs tos,tos jmp #doNEXT _NEG neg tos,tos jmp #doNEXT ' *** Speicher Hub-RAM *** WFETCH rdword tos,tos jmp #doNEXT WPLUSSTORE rdword REG_A,tos add tos+1,REG_A WSTORE wrword tos+1,tos jmp #drop2 CFETCHINC mov REG_A,tos call #dspush add tos+1,#1 CFETCH rdbyte tos,tos jmp #doNEXT CSTORE wrbyte tos+1,tos jmp #drop2 CMOVE rdbyte REG_A,tos+2 add tos+2,#1 wrbyte REG_A,tos add tos,#1 djnz tos+1,#CMOVE jmp #drop3 ' *** Stringfunktionen *** NAMEEQ mov REG_A,#$0F jmp #CSTREQ1 CSTREQ mov REG_A,#$FF CSTREQ1 call #streq jmp #DROP streq rdbyte REG_B,tos+1 wz if_nz and REG_B,REG_A wz if_z jmp #STREQ_ret rdbyte REG_A,tos cmp REG_A,REG_B wz if_nz mov tos+1,#0 if_nz jmp streq_ret :loop add tos+1,#1 rdbyte REG_A,tos+1 add tos,#1 rdbyte REG_C,tos cmp REG_A,REG_C wz if_z djnz REG_B,#:loop muxz tos+1,_32b streq_ret ret FIND mov REG_D,tos :loop mov tos,REG_D mov REG_A,#$0F call #streq if_nz jmp #:label2 :label1 mov tos+1,REG_D jmp #DROP :label2 mov REG_B,REG_D sub REG_B,#2 rdword REG_D,REG_B wz if_z jmp #:label1 jmp #:loop ' *** Businterface *** APUT mov REG_A,_a1 mov REG_B,_a2 jmp #SPUT BPUT mov REG_A,_b1 mov REG_B,_b2 SPUT waitpeq _hs,_hs and tos,#$FF or tos,REG_A mov outa,tos mov dira,dout or outa,REG_B waitpeq _zero,_hs mov dira,dinp mov outa,_s1 jmp #DROP AGET mov REG_B,_a3 jmp #SGET BGET mov REG_B,_b3 SGET waitpeq _hs,_hs mov outa,REG_B waitpeq _zero,_hs mov REG_A,ina and REG_A,#$FF mov outa,_s1 jmp #pushnext XSTORE mov dira,dout call #setadr and tos+1,#$FF or outa,tos+1 xor outa,_bwr mov dira,dinp mov outa,_s1 jmp #drop2 XFETCH call #setadr mov tos+1,ina and tos+1,#$FF mov outa,_s1 jmp #DROP setadr mov REG_A,tos shr REG_A,#3 and REG_A,_latch or outa,REG_A xor outa,_al mov outa,_s1 mov REG_A,tos shl REG_A,#8 and REG_A,_adr or outa,REG_A xor outa,_ram1 setadr_ret ret ' *** Kontrollstrukturen *** LOOP mov REG_C,#1 jmp #PLOOP1 PLOOP call #dspop mov REG_C,REG_A PLOOP1 call #rspop mov REG_B,REG_A call #rspop add REG_B,REG_C cmp REG_A,REG_B wz,wc if_c add IP,#2 if_c jmp #doNEXT call #rspush mov REG_A,REG_B call #rspush rdword REG_A,IP mov IP,REG_A jmp #doNEXT LEAVE call #rspop mov REG_B,REG_A call #rspop mov REG_A,REG_B call #rspush call #rspush jmp #doNEXT FNEXT call #rspop sub REG_A,#1 wz if_z add IP,#2 if_z jmp #doNEXT call #rspush rdword REG_A,IP mov IP,REG_A jmp #doNEXT INDEX call #rspop call #rspush call #dspush jmp #doNEXT EXECUTE mov REG_A,IP call #rspush call #dspop mov IP,REG_A jmp #doNEXT BRANCH rdword IP,IP jmp #doNEXT ZBRANCH call #dspop cmp REG_A,#0 wz if_z jmp #BRANCH add IP,#2 jmp #doNEXT PERFORM call #dspop mov REG_B,REG_A call #dspop shl REG_A,#1 add REG_A,REG_B rdword REG_A,REG_A jmp #EXIT2 RESET hubop $,#%10000_000 { *** TERMINAL E/A-FUNKTIONEN *** } KEY andn dira,rxpin waitpeq rxpin,rxpin waitpne rxpin,rxpin mov REG_B,_115200baud shr REG_B,#1 add REG_B,_115200baud add REG_B,cnt mov REG_A,#128 :loop waitcnt REG_B,_115200baud and rxpin,ina wz,nr muxnz REG_A,#256 shr REG_A,#1 wc if_nc jmp #:loop jmp #pushnext EMIT or tos,#256 shl tos,#1 mov REG_A,#10 mov REG_B,_115200baud add REG_B,cnt or dira,txpin :loop shr tos,#1 wc muxc outa,txpin waitcnt REG_B,_115200baud djnz REG_A,#:loop jmp #DROP { *** INNERER INTERPRETER *** } EXIT call #rspop EXIT2 mov IP,REG_A doNEXT rdword REG_A,IP add IP,#2 test REG_A,_h8000 wz if_nz jmp REG_A movd :modify,RP add RP,#1 :modify mov IP,IP jmp #EXIT2 { *** STACKROUTINEN *** } rspush movd :modify,RP add RP,#1 :modify mov REG_A,REG_A rspush_ret ret rspop sub RP,#1 movs :modify,RP nop :modify mov REG_A,REG_A rspop_ret ret dspush cmp depth,#16 wc mov REG_B,stkptr add REG_B,depth if_nc wrlong tos+3,REG_B mov tos+3,tos+2 mov tos+2,tos+1 mov tos+1,tos mov tos,REG_A add depth,#4 dspush_ret ret dspop mov REG_A,tos mov tos,tos+1 mov tos+1,tos+2 mov tos+2,tos+3 tjz depth,dspush_ret sub depth,#4 testn depth,#%1111 wz if_z jmp dspop_ret mov REG_B,stkptr add REG_B,depth rdlong tos+3,REG_B dspop_ret ret { *** REGISTER UND KONSTANTEN *** } rxpin long |< 31 txpin long |< 30 _115200baud long 694 _h8000 long $8000 _16b long $0000FFFF _32b long $FFFFFFFF _al long %00000000_10000000_00000000_00000000 _bwr long %00000100_00000000_00000000_00000000 _ram1 long %00000000_00001000_00000000_00000000 _latch long %00000000_00000000_11111111_00000000 _adr long %00000000_00000111_11111111_00000000 dinp long %00000111_11111111_11111111_00000000 dout long %00000111_11111111_11111111_11111111 _s1 long %00000100_01111000_00000000_00000000 _b1 long %00000000_00111000_00000000_00000000 _b2 long %00000010_00111000_00000000_00000000 _b3 long %00000110_00111000_00000000_00000000 _a1 long %00000000_01011000_00000000_00000000 _a2 long %00000010_01011000_00000000_00000000 _a3 long %00000110_01011000_00000000_00000000 _hs long %00001000_00000000_00000000_00000000 _zero long %00000000_00000000_00000000_00000000 IP long 0 RP long 0 REG_A long 0 REG_B long 0 REG_C long 0 REG_D long 0 retstk0 long (@retstk - @vm) / 4 stkptr long $7000 depth long 0 tos datastk long 0[4] retstk long 0[32] ' long 0[496-$] fit 496 DAT { ************************* FORTH-WÖRTERBUCH **************************** } word 0 DP_NFA byte 2,"dp" DP_PFA word (@_DATA - @vm) / 4 + PRIM word @@@dp word @@@DP_NFA HERE_NFA byte 4,"here" HERE_PFA word @@@DP_PFA word (@WFETCH - @vm) / 4 + PRIM word (@EXIT - @vm) / 4 + PRIM word @@@HERE_NFA DOTHEX_NFA byte 4,".hex" DOTHEX_PFA word (@TONIB - @vm) / 4 + PRIM word (@LITW - @vm) / 4 + PRIM word $30 word (@PLUS - @vm) / 4 + PRIM word (@DUP - @vm) / 4 + PRIM word (@LITW - @vm) / 4 + PRIM word $39 word (@GT - @vm) / 4 + PRIM word (@ZBRANCH - @vm) / 4 + PRIM word @@@dothex1 word (@LITW - @vm) / 4 + PRIM word 7 word (@PLUS - @vm) / 4 + PRIM dothex1 word (@EMIT - @vm) / 4 + PRIM word (@EXIT - @vm) / 4 + PRIM word @@@DOTHEX_NFA DOTBYTE_NFA byte 5,".byte" DOTBYTE_PFA word (@DUP - @vm) / 4 + PRIM word (@LITW - @vm) / 4 + PRIM word 4 word (@_SHR - @vm) / 4 + PRIM word @@@DOTHEX_PFA word @@@DOTHEX_PFA word (@EXIT - @vm) / 4 + PRIM word @@@DOTBYTE_NFA DOTWORD_NFA byte 5,".word" DOTWORD_PFA word (@DUP - @vm) / 4 + PRIM word (@LITW - @vm) / 4 + PRIM word 8 word (@_SHR - @vm) / 4 + PRIM word @@@DOTBYTE_PFA word @@@DOTBYTE_PFA word (@EXIT - @vm) / 4 + PRIM word @@@DOTWORD_NFA DOTSTR_NFA byte 4,".str" DOTSTR_PFA word (@RPOP - @vm) / 4 + PRIM dotstr1 word (@CFETCHINC - @vm) / 4 + PRIM word (@QDUP - @vm) / 4 + PRIM word (@ZBRANCH - @vm) / 4 + PRIM word @@@dotstr2 word (@EMIT - @vm) / 4 + PRIM word (@BRANCH - @vm) / 4 + PRIM word @@@dotstr1 dotstr2 word (@DUP - @vm) / 4 + PRIM word (@LITW - @vm) / 4 + PRIM word 2 word (@USLASHMOD - @vm) / 4 + PRIM word (@DROP - @vm) / 4 + PRIM word (@PLUS - @vm) / 4 + PRIM word (@PUSHR - @vm) / 4 + PRIM word (@EXIT - @vm) / 4 + PRIM word @@@DOTSTR_NFA QUIT_NFA byte 4,"quit" QUIT_PFA word 0 forth_start word @@@DOTSTR_PFA byte "Hallo Welt!",0 word (@LITW - @vm) / 4 + PRIM word $FF word @@@DOTBYTE_PFA end word (@BRANCH - @vm) / 4 + PRIM word @@@END dp DAT {{ ' ============================================================================= ' TERMS OF USE: MIT Licence ' ============================================================================= ' Permission is hereby granted, free of charge, to any person obtaining a copy ' of this software and associated documentation files (the "Software"), to deal ' in the Software without restriction, including without limitation the rights ' to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ' copies of the Software, and to permit persons to whom the Software is ' furnished to do so, subject to the following conditions: ' ' The above copyright notice and this permission notice shall be included in ' all copies or substantial portions of the Software. ' ' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ' OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ' SOFTWARE. ' ============================================================================= }}