;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; .list .title "msp430 eForth 1.0" .cdecls C,LIST,"msp430g2553.h" ; Include device header file ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; 7/7/2012 430eForth1.0, from eForth86.asm and 430uForth ; ; 7/4/2012 Move 430uForth2.1 from IAR to CCS 5.2 ; 430eForth2.2 ; ; Build for and verified on MSP430G2 LaunchPad from TI ; Assembled with IAR Embedded Workbench IDE ; Only the following FORTH commands are visible to the user: ; + - ! @ C! C@ DUP DROP SWAP OVER AND OR XOR ; . CR TYPE EXECUTE EXIT RED GREEN OFF ; Numbers are unsigned 16-bit integers in hexadecimal only. ; A software UART is implemented. TXD on P1.1. RXD on P1.2. ; On power-up, press "B" or "b" to set baud rate. ; Set terminal baud rate to 2400 baud. Not stable at higher rates. ; Do not disturb TXD and RXD, else the UART will not talk. ; ; Try: ; RED turn on red LED ; GREEN turn on green LED ; OFF turn off both LEDs ; 20 C@ read P1 inputs. Press S2 switch to see the effects. ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; Subroutine Thread Model of eForth ; Only the interpreterr is implemented due to memory limitation. ; Return stack pointer is SP, TOS is R4, and data stack pointer is R5. ; Variables TEMP, CONTEXT, #TIB, >IN and DP are in CPU registers ; R14 and R15 are used by the software UART, for baud rate control. ; It works on MSP430G2231, but may work on other 430 chips. ; The only peripheral used in P1 GPIO port. ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; Inspired by the tinyForth by Luke Chang in Taiwan FIG Chapter ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; CPU registers tos .equ R4 stack .equ R5 temp0 .equ R6 temp1 .equ R7 temp2 .equ R8 temp3 .equ R9 ;; R14-15 used by software UART ;; Memory allocation loadtos .macro mov.w @stack+,tos .endm savetos .macro decd.w stack mov.w tos,0(stack) .endm;; Constants COMPO .equ 040H ;lexicon compile only bit IMEDD .equ 080H ;lexicon immediate bit MASKK .equ 07F1FH ;lexicon bit mask CELLL .equ 2 ;size of a cell BASEE .equ 10 ;default radix VOCSS .equ 8 ;depth of vocabulary stack BKSPP .equ 8 ;backspace LF .equ 10 ;line feed CRR .equ 13 ;carriage return ERR .equ 27 ;error escape TIC .equ 39 ;tick CALLL .equ 012B0H ;NOP CALL opcodes UPP .equ 200H DPP .equ 220H SPP .equ 378H ;data stack TIBB .equ 380H ;terminal input buffer RPP .equ 3F8H ;return stacl CODEE .equ 0C000H ;code dictionary COLDD .equ 0FFFEH ;cold start vector EM .equ 0FFFFH ;top of memory ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Main entry points and COLD start data .text main: init: nop ; main program mov #RPP,SP ; set up stack clr tos mov #SPP,stack mov.w #WDTPW+WDTHOLD,&WDTCTL ; Stop watchdog timer mov #FWKEY+FSSEL1+FN0,&FCTL2 ; SMCLK/2 bis.b #043h,&P1DIR ; P1.0 output ; call #DIAGNOSE call #STOIO ;setup2 ; call #KEY ; call #EMIT ; jmp setup2 br #COLD ;; Device dependent I/O ; KEY ( -- c ) ; Return input character. .word 0 .byte 3,"KEY" KEY savetos clr tos ;receiver buffer key1 bit.b #4,&P1IN ;wait for start bit jnz key1 ; bis.b #1,&P1OUT ;turn on red LED mov r15,r14 rra r14 call #delay1 ;delay half bit time mov #8,temp0 key2 call #delay ; bit.b #4,&P1IN rrc.b tos key3 dec temp0 jnz key2 call #delay ;stop bit ; bic.b #1,&P1OUT ;turn off red LED ret delay mov r15,r14 delay1 bit.b #4,&P1IN dec r14 jnz delay1 ret ; EMIT ( c -- ) ; Send character c to the output device. .word KEY-4 .byte 4,"EMIT",0 EMIT ; bis.b #40h,&P1OUT ;turn on green LED bic.b #2,&P1OUT mov #8,temp0 ;send 8 data bits emit1 call #delay ;start bit rrc.b tos ;shift LSB to carry jc emit2 bic.b #2,&P1OUT jmp emit3 emit2 bis.b #2,&P1OUT emit3 dec temp0 jnz emit1 call #delay ;last bit bis.b #2,&P1OUT ;idle TXD call #delay ;stop bit ; bic.b #40h,&P1OUT ;turn off green LED loadtos ret ; !IO ( -- ) ; Initialize the serial I/O devices. .word EMIT-6 .byte 3,"!IO" STOIO clr r15 ;wait for a "B" character from receiver bis.b #043h,&P1OUT ;idle, TXD, turn on both LED"s iosto1 bit.b #4,&P1IN ;wait for start bit jnz iosto1 bic.b #041h,&P1OUT ;idle TXD, turn off both LED"s iosto2 inc r15 bit.b #4,&P1IN ;wait for a "B" jz iosto2 ;R15 has count for 2 bittime rra r15 ;1 bittime bic.b #041H,&P1OUT ;turn off LED"s ret ;; The kernel ; doLIT ( -- w ) ; Push an inline literal. .word STOIO-4 .byte COMPO+5,"doLIT" DOLIT savetos pop temp0 mov @temp0+,tos br temp0 ; EXIT ( -- ) ; Terminate a colon definition. .word DOLIT-6 .byte 4,"EXIT" EXIT pop temp0 ret ; EXECUTE ( ca -- ) ; Execute the word at ca. .word EXIT-6 .byte 7,"EXECUTE" EXECU mov tos,temp0 loadtos br temp0 ; next ( -- ) ; Run time code for the single index loop. ; : next ( -- ) \ hilevel model ; r> r> dup if 1 - >r @ >r exit then drop cell+ >r ; .word EXECU-8 .byte COMPO+4,"next",0 DONXT pop temp0 dec 0(SP) ;decrement index jge NEXT1 pop temp1 ;discard index incd temp0 br temp0 NEXT1: br @temp0 ; ?branch ( f -- ) ; Branch if flag is zero. .word DONXT-6 .byte COMPO+7,"?branch" QBRAN pop temp0 bit #0xFFFF,tos loadtos jz BRAN1 incd temp0 br temp0 ; branch ( -- ) ; Branch to an inline address. .word QBRAN-8 .byte COMPO+6,"branch",0 BRAN pop temp0 BRAN1: br @temp0 ; ! ( w a -- ) ; Pop the data stack to memory. .word BRAN-8 .byte 1,"!" STORE mov.w @stack+,0(tos) mov.w @stack+,tos ret ; @ ( a -- w ) ; Push memory location to the data stack. .word STORE-2 .byte 1,"@" AT mov.w @tos,tos ret ; C! ( c b -- ) ; Pop the data stack to byte memory. .word AT-2 .byte 2,"C!",0 CSTOR mov.b @stack+,0(tos) inc stack mov.w @stack+,tos ret ; C@ ( b -- c ) ; Push byte memory location to the data stack. .word CSTOR-4 .byte 2,"C@",0 CAT mov.b @tos,tos ret ; R> ( -- w ) ; Pop the return stack to the data stack. .word CAT-4 .byte 2,"R",3EH,0 RFROM savetos pop temp0 pop tos br temp0 ; R@ ( -- w ) ; Copy top of return stack to the data stack. .word RFROM-4 .byte 2,"R@",0 RAT savetos pop temp0 pop tos push tos br temp0 ; >R ( w -- ) ; Push the data stack to the return stack. .word RAT-4 .byte COMPO+2,">R",0 TOR pop temp0 push tos loadtos br temp0 ; SP@ ( -- a ) ; Push the current data stack pointer. .word TOR-4 .byte 3,"SP@" SPAT: mov.w stack,temp0 savetos mov.w temp0,tos ret ; DROP ( w -- ) ; Discard top stack item. .word SPAT-4 .byte 4,"DROP",0 DROP loadtos ret ; DUP ( w -- w w ) ; Duplicate the top stack item. .word DROP-6 .byte 3,"DUP" DUPP savetos ret ; SWAP ( w1 w2 -- w2 w1 ) ; Exchange top two stack items. .word DUPP-4 .byte 4,"SWAP",0 SWAP mov.w tos,temp0 mov.w @stack,tos mov.w temp0,0(stack) ret ; OVER ( w1 w2 -- w1 w2 w1 ) ; Copy second stack item to top. .word SWAP-6 .byte 4,"OVER",0 OVER mov.w @stack,temp0 savetos mov.w temp0,tos ret ; 0< ( n -- t ) ; Return true if n is negative. .word SWAP-6 .byte 2,"0",3CH,0 ZLESS tst tos mov #0xFFFF,tos jn ZLESS1 clr tos ZLESS1: ret ; AND ( w w -- w ) ; Bitwise AND. .word ZLESS-4 .byte 3,"AND" ANDD and @stack+,tos ret ; OR ( w w -- w ) ; Bitwise inclusive OR. .word ANDD-4 .byte 2,"OR",0 ORR bis @stack+,tos ret ; XOR ( w w -- w ) ; Bitwise exclusive OR. .word ORR-4 .byte 3,"XOR" XORR xor @stack+,tos ret ; UM+ ( w w -- w cy ) ; Add two numbers, return the sum and carry flag. .word XORR-4 .byte 3,"UM+" UPLUS clr temp0 add @stack,tos rlc temp0 mov tos,0(stack) mov temp0,tos ret ;; System and user variables ; BASE ( -- a ) ; Storage of the radix base for numeric I/O. .word UPLUS-4 .byte 4,"BASE",0 BASE savetos mov #202H,tos ret ; tmp ( -- a ) ; A temporary storage location used in parse and find. .word BASE-6 .byte COMPO+3,"tmp" TEMP savetos mov #204H,tos ret ; #TIB ( -- a ) ; Hold the character pointer while parsing input stream. .word TEMP-4 .byte 4,"#TIB",0 NTIB savetos mov #206H,tos ret ; >IN ( -- a ) ; Hold the character pointer while parsing input stream. .word NTIB-6 .byte 3,">IN" INN savetos mov #208H,tos ret ; HLD ( -- a ) ; Hold a pointer in building a numeric output string. .word INN-4 .byte 3,"HLD" HLD savetos mov #20AH,tos ret ; 'EVAL ( -- a ) ; A area to specify vocabulary search order. .word HLD-4 .byte 7,"'EVAL" TEVAL savetos mov #20CH,tos ret ; CONTEXT ( -- a ) ; A area to specify vocabulary search order. .word TEVAL-6 .byte 7,"CONTEXT" CNTXT savetos mov #20EH,tos ret ; CP ( -- a ) ; Point to the top of the code dictionary. .word CNTXT-8 .byte 2,"CP",0 CP savetos mov #210H,tos ret ; DP ( -- a ) ; Point to the bottom of the free ram area. .word CP-4 .byte 2,"DP",0 DP savetos mov #212H,tos ret ; LAST ( -- a ) ; Point to the last name in the name dictionary. .word DP-4 .byte 4,"LAST",0 LAST savetos mov #214H,tos ret ;; Common functions ; ?DUP ( w -- w w | 0 ) ; Dup tos if its is not zero. .word LAST-6 .byte 4,"?DUP",0 QDUP tst tos jnz DUPP ret ; ROT ( w1 w2 w3 -- w2 w3 w1 ) ; Rot 3rd item to top. .word QDUP-6 .byte 3,"ROT" ROT call #TOR call #SWAP call #RFROM call #SWAP ret ; 2DROP ( w w -- ) ; Discard two items on stack. .word ROT-4 .byte 5,"2DROP" DDROP call #DROP CALL #DROP ret ; 2DUP ( w1 w2 -- w1 w2 w1 w2 ) ; Duplicate top two items. .word DDROP-6 .byte 4,"2DUP",0 DDUP call #OVER call #OVER ret ; + ( w w -- sum ) ; Add top two items. .word DDUP-6 .byte 1,"+" PLUS add @stack+,tos ret ; D+ ( d d -- d ) ; Double addition, as an example using UM+. ; .word PLUS-2 .byte 2,"D+",0 DPLUS ; call #TOR call #SWAP call #TOR call #UPLUS ; call #RFROM call #RFROM call #PLUS call #PLUS ret ; NOT ( w -- w ) ; One's complement of tos. .word DPLUS-4 .byte 3,"NOT" INVER inv tos ret ; 2/ ( w -- w ) ; Divide by 2. .word INVER-4 .byte 2,"2/",0 TWOSL rra tos ret ; NEGATE ( n -- -n ) ; Two's complement of tos. .word INVER-4 .byte 6,"NEGATE",0 NEGAT inv tos inc tos ret ; DNEGATE ( d -- -d ) ; Two's complement of top double. .word NEGAT-8 .byte 7,"DNEGATE" DNEGA call #INVER call #TOR call #INVER call #DOLIT .word 1 call #UPLUS call #RFROM call #PLUS ret ; - ( n1 n2 -- n1-n2 ) ; Subtraction. .word DNEGA-8 .byte 1,"-" SUBB sub @stack+,tos inv tos inc tos ret ; ABS ( n -- n ) ; Return the absolute value of n. .word SUBB-2 .byte 3,"ABS" ABSS call #DUPP call #ZLESS call #QBRAN .word ABS1 call #NEGAT ABS1: ret ; = ( w w -- t ) ; Return true if top two are equal. .word ABSS-4 .byte 1,3DH EQUAL call #XORR call #QBRAN .word EQU1 call #DOLIT .word 0 ret ;false flag EQU1: call #DOLIT .word -1 ret ;true flag ; U< ( u u -- t ) ; Unsigned compare of top two items. .word EQUAL-2 .byte 2,"U",3CH,0 ULESS mov @stack+,temp0 cmp tos,temp0 subc tos,tos ret ; < ( n1 n2 -- t ) ; Signed compare of top two items. .word ULESS-4 .byte 1,3CH LESS call #DDUP call #XORR call #ZLESS call #QBRAN .word LESS1 call #DROP call #ZLESS ret LESS1: call #SUBB call #ZLESS ret ; MAX ( n n -- n ) ; Return the greater of two top stack items. .word LESS-2 .byte 3,"MAX" MAX call #DDUP call #LESS call #QBRAN .word MAX1 call #SWAP MAX1: call #DROP ret ; MIN ( n n -- n ) ; Return the smaller of top two stack items. .word MAX-4 .byte 3,"MIN" MIN call #DDUP call #SWAP call #LESS call #QBRAN .word MIN1 call #SWAP MIN1: call #DROP ret ; WITHIN ( u ul uh -- t ) ; Return true if u is within the range of ul and uh. .word MIN-4 .byte 6,"WITHIN",0 WITHI call #OVER call #SUBB call #TOR ;ul <= u < uh call #SUBB call #RFROM call #ULESS ret ;; Divide ; UM/MOD ( udl udh u -- ur uq ) ; Unsigned divide of a double by a single. Return mod and quotient. .word WITHI-8 .byte 6,"UM/MOD",0 UMMOD call #DDUP call #ULESS call #QBRAN .word UMM4 call #NEGAT call #DOLIT .word 15 call #TOR UMM1: call #TOR call #DUPP call #UPLUS call #TOR call #TOR call #DUPP call #UPLUS call #RFROM call #PLUS call #DUPP call #RFROM call #RAT call #SWAP call #TOR call #UPLUS call #RFROM call #ORR call #QBRAN .word UMM2 call #TOR call #DROP add #1,tos call #RFROM call #BRAN .word UMM3 UMM2: call #DROP UMM3: call #RFROM call #DONXT .word UMM1 call #DROP call #SWAP ret UMM4: call #DROP call #DDROP call #DOLIT .word -1 call #DUPP ret ;overflow, return max ; M/MOD ( d n -- r q ) ; Signed floored divide of double by single. Return mod and quotient. .word UMMOD-8 .byte 5,"M/MOD" MSMOD call #DUPP call #ZLESS call #DUPP call #TOR call #QBRAN .word MMOD1 call #NEGAT call #TOR call #DNEGA call #RFROM MMOD1: call #TOR call #DUPP call #ZLESS call #QBRAN .word MMOD2 call #RAT call #PLUS MMOD2: call #RFROM call #UMMOD call #RFROM call #QBRAN .word MMOD3 call #SWAP call #NEGAT call #SWAP MMOD3: ret ; /MOD ( n n -- r q ) ; Signed divide. Return mod and quotient. .word MSMOD-6 .byte 4,"/MOD",0 SLMOD call #OVER call #ZLESS call #SWAP call #MSMOD ret ; MOD ( n n -- r ) ; Signed divide. Return mod only. .word SLMOD-6 .byte 3,"MOD" MODD call #SLMOD call #DROP ret ; / ( n n -- q ) ; Signed divide. Return quotient only. .word MODD-4 .byte 1,"/" SLASH call #SLMOD call #SWAP call #DROP ret ;; Multiply ; UM* ( u u -- ud ) ; Unsigned multiply. Return double product. .word SLASH-2 .byte 3,"UM*" UMSTA call #DOLIT .word 0 call #SWAP call #DOLIT .word 15 call #TOR UMST1: call #DUPP call #UPLUS call #TOR call #TOR call #DUPP call #UPLUS call #RFROM call #PLUS call #RFROM call #QBRAN .word UMST2 call #TOR call #OVER call #UPLUS call #RFROM call #PLUS UMST2: call #DONXT .word UMST1 call #ROT jmp DROP ; * ( n n -- n ) ; Signed multiply. Return single product. .word UMSTA-4 .byte 1,"*" STAR call #UMSTA jmp DROP ; M* ( n n -- d ) ; Signed multiply. Return double product. .word STAR-2 .byte 2,"M*" MSTAR call #DDUP call #XORR call #ZLESS call #TOR call #ABSS call #SWAP call #ABSS call #UMSTA call #RFROM call #QBRAN .word MSTA1 call #DNEGA MSTA1: ret ; */MOD ( n1 n2 n3 -- r q ) ; Multiply n1 and n2, then divide by n3. Return mod and quotient. .word MSTAR-4 .byte 5,"*/MOD" SSMOD call #TOR call #MSTAR call #RFROM call #MSMOD ret ; */ ( n1 n2 n3 -- q ) ; Multiply n1 by n2, then divide by n3. Return quotient only. .word SSMOD-6 .byte 2,"*/" STASL call #SSMOD call #SWAP call #DROP ret ;; Miscellaneous ; CELL+ ( a -- a ) ; Add cell size in byte to address. .word STASL-4 .byte 5,"CELL+" CELLP add #2,tos ret ; CELL- ( a -- a ) ; Subtract cell size in byte from address. .word CELLP-6 .byte 5,"CELL-" CELLM sub #2,tos ret ; CELLS ( n -- n ) ; Multiply tos by cell size in bytes. .word CELLM-6 .byte 5,"CELLS" CELLS rla tos ret ; ALIGNED ( b -- a ) ; Align address to the cell boundary. .word CELLS-6 .byte 7,"ALIGNED" ALGND add #1,tos bic #1,tos ret ; BL ( -- 32 ) ; Return 32, the blank character. .word ALGND-8 .byte 2,"BL",0 BLANK savetos mov #20H,tos ret ; >CHAR ( c -- c ) ; Filter non-printing characters. .word BLANK-4 .byte 5,">CHAR" TCHAR call #DUPP ;mask msb call #BLANK call #DOLIT .word 127 call #WITHI ;check for printable call #QBRAN .word TCHA1 ret TCHA1: call #DROP call #DOLIT .word "_" ;replace non-printables ret ; DEPTH ( -- n ) ; Return the depth of the data stack. .word TCHAR-6 .byte 5,"DEPTH" DEPTH call #SPAT call #DOLIT .word SPP call #SWAP call #SUBB jmp TWOSL ; PICK ( ... +n -- ... w ) ; Copy the nth stack item to tos. .word DEPTH-6 .byte 4,"PICK",0 PICK ; add #1,tos call #CELLS call #SPAT call #PLUS call #AT ret ;; Memory access ; +! ( n a -- ) ; Add n to the contents at address a. .word PICK-6 .byte 2,"+!",0 PSTOR call #SWAP call #OVER call #AT call #PLUS call #SWAP call #STORE ret ; 2! ( d a -- ) ; Store the double integer to address a. .word PSTOR-4 .byte 2,"2!",0 DSTOR call #SWAP call #OVER call #STORE call #CELLP call #STORE ret ; 2@ ( a -- d ) ; Fetch double integer from address a. .word DSTOR-4 .byte 2,"2@",0 DAT call #DUPP call #CELLP call #AT call #SWAP call #AT ret ; COUNT ( b -- b +n ) ; Return count byte of a string and add 1 to byte address. .word DAT-4 .byte 5,"COUNT" COUNT mov.b @tos+,temp0 savetos mov temp0,tos ret ; HERE ( -- a ) ; Return the top of the code dictionary. .word COUNT-6 .byte 4,"HERE" HERE call #DP call #AT ret ; PAD ( -- a ) ; Return the address of a temporary buffer. .word HERE-6 .byte 3,"PAD" PAD call #HERE add #50,tos ret ; TIB ( -- a ) ; Return the address of the terminal input buffer. .word PAD-4 .byte 3,"TIB" TIB Savetos Mov #TIBB,tos Ret ; @EXECUTE ( a -- ) ; Execute vector stored in address a. .word TIB-4 .byte 8,"@EXECUTE",0 ATEXE call #AT call #QDUP ;?address or zero call #QBRAN .word EXE1 call #EXECU ;execute if non-zero EXE1: ret ;do nothing if zero ; CMOVE ( b1 b2 u -- ) ; Copy u bytes from b1 to b2. .word ATEXE-10 .byte 5,"CMOVE" CMOVE call #TOR call #BRAN .word CMOV2 CMOV1: call #TOR call #COUNT call #RAT call #CSTOR call #RFROM, add #1,tos CMOV2: call #DONXT .word CMOV1 call #DDROP ret ; FILL ( b u c -- ) ; Fill u bytes of character c to area beginning at b. .word CMOVE-6 .byte 4,"FILL",0 FILL call #SWAP call #TOR call #SWAP call #BRAN .word FILL2 FILL1: call #DDUP call #CSTOR add #1,tos FILL2: call #DONXT .word FILL1 call #DDROP ret ;; Numeric output, single precision ; DIGIT ( u -- c ) ; Convert digit u to a character. .word FILL-6 .byte 5,"DIGIT" DIGIT call #DOLIT .word 9 call #OVER call #LESS call #DOLIT .word 7 call #ANDD call #PLUS add #"0",tos ; call #DOLIT ; .word "0" ; call #PLUS ret ; EXTRACT ( n base -- n c ) ; Extract the least significant digit from n. .word DIGIT-6 .byte 7,"EXTRACT" EXTRC call #DOLIT .word 0 call #SWAP call #UMMOD call #SWAP call #DIGIT ret ; <# ( -- ) ; Initiate the numeric output process. .word EXTRC-8 .byte 2,"<#",0 BDIGS call #PAD call #HLD call #STORE ret ; HOLD ( c -- ) ; Insert a character into the numeric output string. .word BDIGS-4 .byte 4,"HOLD",0 HOLD call #HLD call #AT, sub #1,tos call #DUPP call #HLD call #STORE call #CSTOR ret ; # ( u -- u ) ; Extract one digit from u and append the digit to output string. .word HOLD-6 .byte 1,"#" DIG call #BASE call #AT call #EXTRC call #HOLD ret ; #S ( u -- 0 ) ; Convert u until all digits are added to the output string. .word DIG-2 .byte 2,"#S",0 DIGS DIGS1: call #DIG call #DUPP call #QBRAN .word DIGS2 call #BRAN .word DIGS1 DIGS2: ret ; SIGN ( n -- ) ; Add a minus sign to the numeric output string. .word DIGS-4 .byte 4,"SIGN",0 SIGN call #ZLESS call #QBRAN .word SIGN1 call #DOLIT .word "-" call #HOLD SIGN1: ret ; #> ( w -- b u ) ; Prepare the output string to be TYPE'd. .word SIGN-6 .byte 2,"#",3EH,0 EDIGS call #DROP call #HLD call #AT call #PAD call #OVER call #SUBB ret ; str ( n -- b u ) ; Convert a signed integer to a numeric string. .word EDIGS-4 .byte 3,"str" STR call #DUPP call #TOR call #ABSS call #BDIGS call #DIGS call #RFROM call #SIGN call #EDIGS ret ; HEX ( -- ) ; Use radix 16 as base for numeric conversions. .word STR-4 .byte 3,"HEX" HEX call #DOLIT .word 16 call #BASE call #STORE ret ; DECIMAL ( -- ) ; Use radix 10 as base for numeric conversions. .word HEX-4 .byte 7,"DECIMAL" DECIM call #DOLIT .word 10 call #BASE call #STORE ret ;; Numeric input, single precision ; DIGIT? ( c base -- u t ) ; Convert a character to its numeric value. A flag indicates success. .word DECIM-8 .byte 6,"DIGIT?",0 DIGTQ call #TOR, sub #"0",tos ; call #DOLIT ; .word "0" ; call #SUBB call #DOLIT .word 9 call #OVER call #LESS call #QBRAN .word DGTQ1 sub #7,tos call #DUPP, call #DOLIT .word 10 call #LESS call #ORR DGTQ1: call #DUPP call #RFROM call #ULESS ret ; NUMBER? ( a -- n T | a F ) ; Convert a number string to integer. Push a flag on tos. .word DIGTQ-8 .byte 7,"NUMBER?" NUMBQ call #BASE call #AT call #TOR, call #DOLIT .word 0 call #OVER call #COUNT call #OVER call #CAT, call #DOLIT .word "$" Call #EQUAL call #QBRAN .word NUMQ1 call #HEX call #SWAP add #1,tos call #SWAP sub #1,tos NUMQ1: call #OVER call #CAT, call #DOLIT .word "-" Call #EQUAL call #TOR call #SWAP call #RAT call #SUBB call #SWAP call #RAT call #PLUS call #QDUP call #QBRAN .word NUMQ6 sub #1,tos call #TOR NUMQ2: call #DUPP call #TOR call #CAT call #BASE call #AT call #DIGTQ call #QBRAN .word NUMQ4 call #SWAP call #BASE call #AT call #STAR call #PLUS call #RFROM add #1,tos call #DONXT .word NUMQ2 call #RAT call #SWAP call #DROP call #QBRAN .word NUMQ3 call #NEGAT NUMQ3: call #SWAP call #BRAN .word NUMQ5 NUMQ4: call #RFROM call #RFROM call #DDROP call #DDROP, call #DOLIT .word 0 NUMQ5: call #DUPP NUMQ6: call #RFROM call #DDROP call #RFROM call #BASE call #STORE ret ;; Basic I/O ; SPACE ( -- ) ; Send the blank character to the output device. .word NUMBQ-8 .byte 5,"SPACE" SPACE call #BLANK call #EMIT ret ; SPACES ( +n -- ) ; Send n spaces to the output device. .word SPACE-6 .byte 6,"SPACES",0 SPACS call #DOLIT .word 0 call #MAX call #TOR call #BRAN .word CHAR2 CHAR1: call #SPACE CHAR2: call #DONXT .word CHAR1 ret ; TYPE ( b u -- ) ; Output u characters from b. .word SPACS-8 .byte 4,"TYPE",0 TYPEE call #TOR call #BRAN .word TYPE2 TYPE1: call #DUPP call #CAT call #TCHAR call #EMIT add #1,tos TYPE2: call #DONXT .word TYPE1 call #DROP ret ; CR ( -- ) ; Output a carriage return and a line feed. .word TYPEE-6 .byte 2,"CR",0 CR call #DOLIT .word CRR call #EMIT call #DOLIT .word LF call #EMIT ret ; do$ ( -- a ) ; Return the address of a compiled string. .word CR-4 .byte COMPO+3,"do$" DOSTR call #RFROM call #RAT call #RFROM call #COUNT call #PLUS call #ALGND call #TOR call #SWAP call #TOR ret ; $"| ( -- a ) ; Run time routine compiled by $". Return address of a compiled string. .word DOSTR-4 .byte COMPO+3,"$""|" STRQP call #DOSTR ret ;force a call to do$ ; ."| ( -- ) ; Run time routine of ." . Output a compiled string. .word STRQP-4 .byte COMPO+3,".""|" DOTQP call #DOSTR call #COUNT call #TYPEE ret ; .R ( n +n -- ) ; Display an integer in a field of n columns, right justified. .word DOTQP-4 .byte 2,".R",0 DOTR call #TOR call #STR call #RFROM call #OVER call #SUBB call #SPACS call #TYPEE ret ; U.R ( u +n -- ) ; Display an unsigned integer in n column, right justified. .word DOTR-4 .byte 3,"U.R" UDOTR call #TOR call #BDIGS call #DIGS call #EDIGS call #RFROM call #OVER call #SUBB call #SPACS call #TYPEE ret ; U. ( u -- ) ; Display an unsigned integer in free format. .word UDOTR-4 .byte 2,"U.",0 UDOT call #BDIGS call #DIGS call #EDIGS call #SPACE call #TYPEE ret ; . ( w -- ) ; Display an integer in free format, preceeded by a space. .word UDOT-4 .byte 1,"." DOT call #BASE call #AT call #DOLIT .word 10 call #XORR ;?decimal call #QBRAN .word DOT1 jmp UDOT DOT1: call #STR call #SPACE jmp TYPEE ; ? ( a -- ) ; Display the contents in a memory cell. .word DOT-2 .byte 1,"?" QUEST call #AT call #DOT ret ;; Parsing ; parse ( b u c -- b u delta ; ) ; Scan string delimited by c. Return found string and its offset. .word QUEST-2 .byte 5,"parse" PARS call #TEMP call #STORE call #OVER call #TOR call #DUPP call #QBRAN .word PARS8 sub #1,tos call #TEMP call #AT call #BLANK call #EQUAL call #QBRAN .word PARS3 call #TOR PARS1: call #BLANK call #OVER call #CAT ;skip leading blanks ONLY call #SUBB call #ZLESS call #INVER call #QBRAN .word PARS2 add #1,tos call #DONXT .word PARS1 call #RFROM call #DROP, call #DOLIT .word 0 call #DUPP ret PARS2: call #RFROM PARS3: call #OVER call #SWAP call #TOR PARS4: call #TEMP call #AT call #OVER call #CAT call #SUBB ;scan for delimiter call #TEMP call #AT call #BLANK call #EQUAL call #QBRAN .word PARS5 call #ZLESS PARS5: call #QBRAN .word PARS6 add #1,tos call #DONXT .word PARS4 call #DUPP call #TOR call #BRAN .word PARS7 PARS6: call #RFROM call #DROP call #DUPP add #1,tos call #TOR PARS7: call #OVER call #SUBB call #RFROM call #RFROM call #SUBB ret PARS8: call #OVER call #RFROM call #SUBB ret ; PARSE ( c -- b u ; ) ; Scan input stream and return counted string delimited by c. .word PARS-6 .byte 5,"PARSE" PARSE call #TOR call #TIB call #INN call #AT call #PLUS ;current input buffer pointer call #NTIB call #AT call #INN call #AT call #SUBB ;remaining count call #RFROM call #PARS call #INN call #PSTOR ret ; .( ( -- ) ; Output following string up to next ) . .word PARSE-6 .byte IMEDD+2,".(",0 DOTPR call #DOLIT .word ")" Call #PARSE call #TYPEE ret ; ( ( -- ) ; Ignore following string up to next ) . A comment. .word DOTPR-4 .byte IMEDD+1,"(" PAREN call #DOLIT .word ")" Call #PARSE call #DDROP ret ; \ ( -- ) ; Ignore following text till the end of line. .word PAREN-2 .byte IMEDD+1,"\" BKSLA call #NTIB call #AT call #INN call #STORE ret ; CHAR ( -- c ) ; Parse next word and return its first character. .word BKSLA-2 .byte 4,"CHAR",0 CHAR call #BLANK call #PARSE call #DROP call #CAT ret ; TOKEN ( -- a ; ) ; Parse a word from input stream and copy it to name dictionary. .word CHAR-6 .byte 5,"TOKEN" TOKEN call #BLANK call #PARSE call #DOLIT .word 31 call #MIN TOKEN1 call #HERE call #DDUP call #CSTOR add #1,tos call #SWAP call #CMOVE jmp HERE ; WORD ( c -- a ; ) ; Parse a word from input stream and copy it to code dictionary. .word TOKEN-6 .byte 4,"WORD",0 WORDD call #PARSE jmp TOKEN1 ;; Dictionary search ; NAME> ( na -- ca ) ; Return a code address given a name address. .word WORDD-6 .byte 5,"NAME>" NAMET call #COUNT and #1FH,tos call #PLUS jmp ALGND ; SAME? ( a a u -- a a f \ -0+ ) ; Compare u cells in two strings. Return 0 if identical. .word NAMET-6 .byte 5,"SAME?" SAMEQ call #OVER call #CAT SAME1: mov 2(stack),temp0 add tos,temp0 mov.b 0(temp0),temp0 mov 0(stack),temp1 add tos,temp1 mov.b 0(temp1),temp1 sub temp1,temp0 jnz SAME2 dec tos jnz SAME1 ret SAME2: mov #-1,tos ret ; NAME? ( a -- ca na | a F ) ; Search all context vocabularies for a string. .word SAMEQ-6 .byte 5,"NAME?" NAMEQ call #CNTXT call #AT FIND1: tst tos jz FIND3 ;end of dictionary call #OVER call #AT call #OVER call #AT call #DOLIT .word MASKK call #ANDD call #EQUAL call #QBRAN .word FIND4 call #SAMEQ call #QBRAN .word FIND2 ;match FIND4 decd tos mov 0(tos),tos jmp FIND1 FIND2 mov tos,0(stack) call #NAMET br #SWAP FIND3: ret ;; Terminal response ; ^H ( bot eot cur -- bot eot cur ) ; Backup the cursor by one character. .word NAMEQ-6 .byte 2,"^H",0 BKSP call #TOR call #OVER call #RFROM call #SWAP call #OVER call #XORR call #QBRAN .word BACK1 call #DOLIT .word BKSPP call #EMIT sub #1,tos call #BLANK call #EMIT call #DOLIT .word BKSPP call #EMIT BACK1: ret ; TAP ( bot eot cur c -- bot eot cur ) ; Accept and echo the key stroke and bump the cursor. .word BKSP-4 .byte 3,"TAP" TAP call #DUPP call #EMIT call #OVER call #CSTOR, add #1,tos ret ; kTAP ( bot eot cur c -- bot eot cur ) ; Process a key stroke, CR or backspace. .word TAP-4 .byte 4,"kTAP",0 KTAP call #DUPP sub #CRR,tos call #QBRAN .word KTAP2 sub #BKSPP,tos call #QBRAN .word KTAP1 call #BLANK jmp TAP KTAP1: jmp BKSP KTAP2: call #DROP call #SWAP call #DROP jmp DUPP ; accept ( b u -- b u ) ; Accept characters to input buffer. Return with actual count. .word KTAP-6 .byte 6,"accept",0 ACCEP call #OVER call #PLUS call #OVER ACCP1: call #DDUP call #XORR call #QBRAN .word ACCP4 call #KEY call #DUPP call #BLANK call #SUBB call #DOLIT .word 95 call #ULESS call #QBRAN .word ACCP2 call #TAP call #BRAN .word ACCP1 ACCP2: call #KTAP ACCP3: jmp ACCP1 ACCP4: call #DROP call #OVER jmp SUBB ; QUERY ( -- ) ; Accept input stream to terminal input buffer. .word ACCEP-8 .byte 5,"QUERY" QUERY call #TIB, call #DOLIT .word 80 call #ACCEP call #NTIB call #STORE call #DROP call #DOLIT .word 0 call #INN call #STORE ret ;; Error handling ; ERROR ( a -- ) ; Return address of a null string with zero count. .word QUERY-6 .byte 5,"ERROR" ERROR: call #SPACE call #COUNT call #TYPEE call #DOLIT .word 3FH call #EMIT call #CR ; call #EMPTY_BUF jmp QUIT ; abort" ( f -- ) ; Run time routine of ABORT" . Abort with a message. .word ERROR-6 .byte COMPO+6,"abort""" ABORQ call #QBRAN .word ABOR1 ;text flag call #DOSTR call #COUNT call #TYPEE jmp QUIT ;pass error string ABOR1: call #DOSTR call #DROP ret ;drop error ;; The text interpreter ; $INTERPRET ( a -- ) ; Interpret a word. If failed, try to convert it to an integer. .word ABORQ-8 .byte 10,"$INTERPRET",0 INTER call #NAMEQ call #QDUP ;?defined call #QBRAN .word INTE1 call #AT call #DOLIT .word COMPO call #ANDD ;?compile only lexicon bits call #ABORQ .byte 13," compile only" call #EXECU ret ;execute defined word INTE1: call #NUMBQ call #QBRAN .word INTE2 ret INTE2: jmp ERROR ;error ; [ ( -- ) ; Start the text interpreter. .word INTER-12 .byte IMEDD+1,"[" LBRAC call #DOLIT .word INTER call #TEVAL call #STORE ret ; .OK ( -- ) ; Display 'ok' only while interpreting. .word LBRAC-2 .byte 3,".OK" DOTOK call #DOLIT .word INTER call #TEVAL call #AT call #EQUAL call #QBRAN .word DOTO1 call #DOTQP .byte 3," ok" DOTO1: call #CR Ret ; ?STACK ( -- ) ; Abort if the data stack underflows. .word DOTOK-4 .byte 6,"?STACK",0 QSTAC call #DEPTH call #ZLESS ;check only for underflow call #ABORQ .byte 10," underflow",0 Ret ; EVAL ( -- ) ; Interpret the input stream. .word QSTAC-8 .byte 4,"EVAL",0 EVAL EVAL1: call #TOKEN call #DUPP call #CAT ;?input stream empty call #QBRAN .word EVAL2 call #TEVAL call #ATEXE call #QSTAC ;evaluate input, check stack call #BRAN .word EVAL1 EVAL2: call #DROP call #DOTOK ret ;prompt ;; Shell ; QUIT ( -- ) ; Reset return stack pointer and start text interpreter. .word EVAL-6 .byte 4,"QUIT",0 QUIT mov #SPP,stack mov #RPP,SP QUIT1: call #LBRAC ;start interpretation QUIT2: call #QUERY ;get input call #EVAL jmp QUIT2 ;continue till error ;; The compiler ; ' ( -- ca ) ; Search context vocabularies for the next word in input stream. .word QUIT-6 .byte 1,"'" TICK call #TOKEN call #NAMEQ ;?defined call #QBRAN .word TICK1 ret ;yes, push code address TICK1: jmp ERROR ;no, error ; ALLOT ( n -- ) ; Allocate n bytes to the RAM dictionary. .word TICK-2 .byte 5,"ALLOT" ALLOT call #DP jmp PSTOR ; IALLOT ( n -- ) ; Allocate n bytes to the code dictionary. .word ALLOT-6 .byte 6,"IALLOT",0 IALLOT call #CP jmp PSTOR ; I! ( n a -- ) ; Store n to address a in code dictionary. .word IALLOT-8 .byte 2,"I!",0 ISTORE mov #FWKEY,&FCTL3 ; Clear LOCK mov #FWKEY+WRT,&FCTL1 ; Enable write call #STORE mov #FWKEY,&FCTL1 ; Done. Clear WRT mov #FWKEY+LOCK,&FCTL3 ; Set LOCK ret ; ERASE ( a -- ) ; Erase a segment at address a. .word ISTORE-4 .byte 5,"ERASE" IERASE mov #FWKEY,&FCTL3 ; Clear LOCK mov #FWKEY+ERASE,&FCTL1 ; Enable erase clr 0(tos) mov #FWKEY+LOCK,&FCTL3 ; Set LOCK loadtos ret ; WRITE ( src dest n -- ) ; Copy n byte from src to dest. Dest is in flash memory. .word IERASE-6 .byte 5,"WRITE" WRITE rra tos call #TOR WRITE1 call #OVER call #AT call #OVER call #ISTORE incd tos incd 0(stack) call #DONXT .word WRITE1 jmp DDROP ; , ( w -- ) ; Compile an integer into the code dictionary. .word WRITE-6 .byte 1,"," COMMA call #CP CALL #AT call #DUPP call #CELLP ;cell boundary call #CP call #STORE jmp ISTORE ; call, ( w -- ) ; Compile a call instruction into the code dictionary. .word COMMA-2 .byte 5,"call," CALLC call #DOLIT .word CALLL call #COMMA jmp COMMA ; [COMPILE] ( -- ; ) ; Compile the next immediate word into code dictionary. .word CALLC-6 .byte IMEDD+9,"[COMPILE]" BCOMP call #TICK jmp CALLC ; COMPILE ( -- ) ; Compile the next address in colon list to code dictionary. .word BCOMP-10 .byte COMPO+7,"COMPILE" COMPI call #RFROM call #DUPP call #AT call #COMMA ;compile call instruction call #CELLP call #DUPP call #AT call #COMMA ;compile address call #CELLP call #TOR ret ;adjust return address ; LITERAL ( w -- ) ; Compile tos to code dictionary as an integer literal. .word COMPI-8 .byte IMEDD+7,"LITERAL" LITER call #DOLIT .word DOLIT call #CALLC jmp COMMA ; $," ( -- ) ; Compile a literal string up to next " . .word LITER-8 .byte 3,"$,""" STRCQ call #DOLIT .word """" call #WORDD ;move string to code dictionary STRCQ1 call #DUPP call #CAT call #TWOSL ;calculate aligned end of string call #TOR STRCQ2 call #DUPP call #AT call #COMMA call #CELLP call #DONXT .word STRCQ2 jmp DROP ;; Structures ; FOR ( -- a ) ; Start a FOR-NEXT loop structure in a colon definition. .word STRCQ-4 .byte IMEDD+3,"FOR" FOR call #DOLIT .word TOR call #CALLC jmp BEGIN ; BEGIN ( -- a ) ; Start an infinite or indefinite loop structure. .word FOR-4 .byte IMEDD+5,"BEGIN" BEGIN call #CP jmp AT ; NEXT ( a -- ) ; Terminate a FOR-NEXT loop structure. .word BEGIN-6 .byte IMEDD+4,"NEXT",0 NEXT call #DOLIT .word DONXT call #CALLC jmp COMMA ; UNTIL ( a -- ) ; Terminate a BEGIN-UNTIL indefinite loop structure. .word NEXT-6 .byte IMEDD+5,"UNTIL" UNTIL call #DOLIT .word QBRAN call #CALLC jmp COMMA ; AGAIN ( a -- ) ; Terminate a BEGIN-AGAIN infinite loop structure. .word UNTIL-6 .byte IMEDD+5,"AGAIN" AGAIN call #DOLIT .word BRAN call #CALLC jmp COMMA ; IF ( -- A ) ; Begin a conditional branch structure. .word AGAIN-6 .byte IMEDD+2,"IF",0 IFF call #DOLIT .word QBRAN call #CALLC call #BEGIN call #DOLIT .word 2 jmp IALLOT ; AHEAD ( -- A ) ; Compile a forward branch instruction. .word IFF-4 .byte IMEDD+5,"AHEAD" AHEAD call #DOLIT .word BRAN call #CALLC call #BEGIN call #DOLIT .word 2 jmp IALLOT ; REPEAT ( A a -- ) ; Terminate a BEGIN-WHILE-REPEAT indefinite loop. .word AHEAD-6 .byte IMEDD+6,"REPEAT",0 REPEA call #AGAIN call #BEGIN call #SWAP jmp ISTORE ; THEN ( A -- ) ; Terminate a conditional branch structure. .word REPEA-8 .byte IMEDD+4,"THEN",0 THENN call #BEGIN call #SWAP jmp ISTORE ; AFT ( a -- a A ) ; Jump to THEN in a FOR-AFT-THEN-NEXT loop the first time through. .word THENN-6 .byte IMEDD+3,"AFT" AFT call #DROP call #AHEAD call #BEGIN jmp SWAP ; ELSE ( A -- A ) ; Start the false clause in an IF-ELSE-THEN structure. .word AFT-4 .byte IMEDD+4,"ELSE",0 ELSEE call #AHEAD call #SWAP jmp THENN ; WHILE ( a -- A a ) ; Conditional branch out of a BEGIN-WHILE-REPEAT loop. .word ELSEE-6 .byte IMEDD+5,"WHILE" WHILE call #IFF jmp SWAP ; ABORT" ( -- ; ) ; Conditional abort with an error message. .word WHILE-6 .byte IMEDD+6,"ABORT""",0 ABRTQ call #DOLIT .word ABORQ call #CALLC jmp STRCQ ; $" ( -- ; ) ; Compile an inline string literal. .word ABRTQ-8 .byte IMEDD+2,"$""",0 STRQ call #DOLIT .word STRQP call #CALLC call #STRCQ ret ; ." ( -- ; ) ; Compile an inline string literal to be typed out at run time. .word STRQ-4 .byte IMEDD+2,".""",0 DOTQ call #DOLIT .word DOTQP call #CALLC call #STRCQ ret ;; Name compiler ; ?UNIQUE ( a -- a ) ; Display a warning message if the word already exists. .word DOTQ-4 .byte 7,"?UNIQUE" UNIQU call #DUPP call #NAMEQ ;?name exists call #QBRAN .word UNIQ1 ;redefinitions are OK call #DOTQP .byte 7," reDef " ;but warn the user call #OVER call #COUNT call #TYPEE ;just in case its not planned UNIQ1: jmp DROP ; $,n ( na -- ) ; Build a new dictionary name using the string at na. .word UNIQU-8 .byte 3,"$,n" SNAME call #DUPP call #CAT ;?null input call #QBRAN .word SNAM1 call #UNIQU ;?redefinition call #LAST call #AT call #COMMA ;save na for vocabulary link call #CP call #AT call #LAST call #STORE jmp STRCQ1 ;fill name field SNAM1 call #STRQP .byte 5," name" ;null input jmp ERROR ;; FORTH compiler ; $COMPILE ( a -- ) ; Compile next word to code dictionary as a token or literal. .word SNAME-4 .byte 8,"$COMPILE",0 SCOMP call #NAMEQ call #QDUP ;?defined call #QBRAN .word SCOM2 call #AT call #DOLIT .word IMEDD call #ANDD ;?immediate call #QBRAN .word SCOM1 jmp EXECU ;its immediate, execute SCOM1: jmp CALLC ;its not immediate, compile SCOM2: call #NUMBQ ;try to convert to number call #QBRAN .word SCOM3 jmp LITER ;compile number as integer SCOM3: jmp ERROR ;error ; OVERT ( -- ) ; Link a new word into the current vocabulary. .word SCOMP-10 .byte 5,"OVERT" OVERT call #LAST call #AT call #CNTXT jmp STORE ; ; ( -- ) ; Terminate a colon definition. .word OVERT-6 .byte IMEDD+COMPO+1,";" SEMIS call #DOLIT ret call #COMMA call #LBRAC jmp OVERT ; ] ( -- ) ; Start compiling the words in the input stream. .word SEMIS-2 .byte 1,"]" RBRAC call #DOLIT .word SCOMP call #TEVAL jmp STORE ; : ( -- ; ) ; Start a new colon definition using next word as its name. .word RBRAC-2 .byte 1,":" COLON call #TOKEN call #SNAME jmp RBRAC ; IMMEDIATE ( -- ) ; Make the last compiled word an immediate word. .word COLON-2 .byte 9,"IMMEDIATE" IMMED call #DOLIT .word IMEDD call #LAST call #AT call #AT call #ORR call #LAST call #AT jmp ISTORE ;; Defining words ; doCON ( -- a ) ; Run time routine forCONSTANT, VARIABLE and CREATE. .word IMMED-10 .byte COMPO+5,"doCON" DOCON: savetos pop tos MOV @tos,tos ret ; HEADER ( -- ; ) ; Compile a new array entry without allocating code space. .word DOCON-6 .byte 6,"HEADER",0 HEADER call #TOKEN call #SNAME call #OVERT call #DOLIT .word DOCON jmp CALLC ; CREATE ( -- ; ) ; Compile a new array entry without allocating code space. .word HEADER-8 .byte 6,"CREATE",0 CREAT call #HEADER call #DP call #AT jmp COMMA ; CONSTANT ( n -- ; ) ; Compile a new constant. .word CREAT-8 .byte 8,"CONSTANT",0 CONST call #HEADER jmp COMMA ; VARIABLE ( -- ; ) ; Compile a new variable initialized to 0. .word CONST-10 .byte 8,"VARIABLE",0 VARIA call #CREAT call #DOLIT .word 2 jmp ALLOT ;; Tools ; DUMP ( a u -- ) ; Dump u bytes from a, in a formatted manner. .word VARIA-10 .byte 4,"DUMP",0 DUMP call #DOLIT .word 7 call #TOR ;start count down loop DUMP1: call #CR, call #DUPP call #DOLIT .word 5 call #UDOTR call #DOLIT .word 15 call #TOR DUMP2 call #COUNT call #DOLIT .word 3 call #UDOTR call #DONXT .word DUMP2 ;loop till done call #SPACE call #DUPP sub #16,tos call #DOLIT .word 16 call #TYPEE ;display printable characters call #DONXT .word DUMP1 ;loop till done jmp DROP ; .S ( ... -- ... ) ; Display the contents of the data stack. .word DUMP-6 .byte 2,".S",0 DOTS call #CR call #DEPTH ;stack depth call #TOR ;start count down loop jmp DOTS2 ;skip first pass DOTS1: call #RAT call #PICK call #DOT ;index stack, display contents DOTS2: call #DONXT .word DOTS1 ;loop till done call #DOTQP .byte 4," NAME ( ca -- na | F ) ; Convert code address to a name address. .word DOTS-4 .byte 5,">NAME" TNAME call #TOR call #CNTXT ;vocabulary link call #AT TNAM1: call #DUPP ;check all vocabularies call #QBRAN .word TNAM2 call #DUPP call #NAMET call #RAT call #XORR ;compare call #QBRAN .word TNAM2 call #CELLM ;continue with next word call #AT call #BRAN .word TNAM1 TNAM2: call #RFROM jmp DROP ; .ID ( na -- ) ; Display the name at address. .word TNAME-6 .byte 3,".ID" DOTID call #COUNT call #DOLIT .word 01FH call #ANDD ;mask lexicon bits jmp TYPEE ; WORDS ( -- ) ; Display the names in the context vocabulary. .word DOTID-4 .byte 5,"WORDS" WORDS call #CR call #CNTXT call #AT ;only in context WORS1: call #QDUP ;?at end of list call #QBRAN .word WORS2 call #DUPP call #SPACE call #DOTID ;display a name call #CELLM call #AT call #BRAN .word WORS1 WORS2: ret ;; Hardware reset ; hi ( -- ) ; Display the sign-on message of eForth. .word WORDS-6 .byte 2,"hi",0 HI ; call #STOIO call #CR ;initialize I/O call #DOTQP .byte 14,"430eForth v1.0",0 ;model jmp CR ; 'BOOT ( -- a ) ; The application startup vector. .word HI-4 .byte 5,"'BOOT" TBOOT savetos mov #UPP,tos ret ; COLD ( -- ) ; The hilevel cold start sequence. .word TBOOT-6 .byte 4,"COLD" COLD COLD1: call #DOLIT .word UZERO call #DOLIT .word UPP call #DOLIT .word ULAST-UZERO call #CMOVE ;initialize user area call #TBOOT call #ATEXE ;application boot call #QUIT ;start interpretation jmp COLD1 ;just in case CTOP .word 0FFFFH ;next available memory in code dictionary ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; COLD start moves the following to USER variables. ; MUST BE IN SAME ORDER AS USER VARIABLES. .sect ".infoD" UZERO: .word HI ;200H, boot routine .word BASEE ;202H, BASE .word 0 ;204H, tmp .word 0 ;206H, >IN .word 0 ;208H, #TIB .word INTER ;20AH, 'EVAL .word 0 ;20CH, HLD .word COLD-6 ;20EH, CONTEXT pointer .word CTOP ;210H, CP .word DPP ;220H, DP .word COLD-6 ;214H, LAST ULAST: ;=============================================================== .sect ".reset" ; MSP430 RESET Vector .short main ; .end ;===============================================================