\ ADDENDUM to KERNER.FAR for AVR ATmega128 by default \ Coded by RZ6AT =============================================================== code 2>R ( d -- ) ( R: -- d ) c( push 2 cells to return stack) pop zh pop zl movw w,x popt push tosl push tosh popt push wl push wh ijmp c; call-only code 2R> ( -- d ) ( R: d -- ) c( pop 2 cells from return stack) pop zh pop zl pusht pop tosh pop tosl pop wh pop wl pushw ijmp c; call-only code U> ( u1 u2 -- f ) c( true if NOS > TOS unsigned) popw cp tosl,wl ldi tosl,0 cpc tosh,wh if_c ldi tosl,-1 then mov tosh,tosl ret c; : U< ( u1 u2 -- f ) SWAP U> ; c( true if NOS < TOS unsigned) code D< ( d1 d2 -- f ) c( true if signed double NOS < signed double TOS ) movw R16,x popt popw popz cp zl,xl cpc zh,xh cpc wl,R16 cpc wh,R17 ldi tosl,-1 if_ge ldi tosl,0 then mov tosh,tosl ret c; : D> ( d1 d2 -- f ) 2swap D< ; c( true if double NOS > double TOS ) hex code DIGIT ( char base -- n f ) c( convert ASCII to digit) \ If the character is equivalent to a digit in the specified base, \ converts the character and return a TRUE flag, else leaves \ char and FALSE. mov R16,xl ser R17 popz \ base->R16 flag->R17 char->z subi zl,30 if_nc cpi R16,0B if_c cpi zl,09 if_c inc R17 else cp zl,R16 if_c inc R17 then then else cpi zl,09 if_c inc R17 else cpi zl,10 if_nc subi zl,7 if_c else cp zl,R16 if_c inc R17 then then then then then then pushz mov xl,R17 ret c; decimal \ ADDED FROM KERNEL.FF ---------------------------------------------------------------\ \ : ALIGN ( -- ) ; c( align to 16 bits addr ) \ : ALIGNED ( -- ) ; c( aligned to 16 bits addr ) \ : UD* ( ud1 u -- ud2 ) c( unsigned 32*16 -> 32 multiply) \ dup >r um* drop swap r> um* rot + ; \ \ : /STRING ( addr len n -- addr' len' ) c( index into the string by n) \ \ Returns addr+n and len-n, n>=0 \ \ over min >r swap r@ + swap r> - ; \ \ : >NUMBER ( ud addr len -- ud' addr' len' ) c( convert string to a number) \ begin dup \ while over c@ base @ digit \ 0= \ if drop exit then \ >r 2swap base @ ud* \ r> 0 d+ 2swap \ 1 /string \ repeat ; \ \ ------------------------------------------------------------------------------------- code 1-1- ( a b -- a-1 b-1 ) c( NOS-1 TOS-1 ) sbiw tos,1 popz sbiw z,1 pushz ret c; code MOVE> ( adr> >adr len -- ) c( MOVE memory from ADR> to >ADR LEN bytes last byte first ) push R24 push R25 movw R24,xl popz popt \ R22,R23 = len Z = >adr X = adr> mov R16,R24 or R16,R25 \ equals to 0?, exit if yes if_nz clc add zL,R24 adc zH,R25 clc add xL,R24 adc xH,R25 begin ld R16,-x \ if not, read from adr> st -z,R16 \ store in >adr sbiw R24,1 \ decrement len until_z \ if equals to 0, then exit then pop R25 pop R24 rjmp DROP c; \ clear stack code >adr len -- ) c( MOVE memory from ADR> to >ADR LEN bytes first byte first ) push R24 push R25 movw R24,xl popz popt \ R22,R23 = len Z = >adr X = adr> mov R16,R24 or R16,R25 \ equals to 0?, exit if yes if_nz begin ld R16,x+ \ if not, read from adr> st z+,R16 \ store in >adr sbiw R24,1 \ decrement len until_z \ if equals to 0, then exit then pop R25 pop R24 rjmp DROP c; \ clear stack code PMOVE ( adr> >adr len -- ) c( MOVE from program memory with ADR> to >ADR LEN bytes) push R24 push R25 movw R24,xl popt popz \ R24,R25 = len Z = >adr X = adr> mov R16,R24 or R16,R25 \ equals to 0?, exit if yes if_nz begin lpm R16,z+ \ if not, read from adr> st x+,R16 \ store in >adr sbiw R24,1 \ decrement len until_z \ if equals to 0, then exit then pop R25 pop R24 rjmp DROP c; \ clear stack code Q+ ( q1 q2 -- q3 ) c( quad-cell add) pusht movw x,y movw z,y \ ah am am am am am am al \ bh bm bm bm bm bm bm bl = [Y] adiw x,8 adiw z,16 \ was 10 \ X -> A Z -> B ==================================== ldi R16,8 clc for ld wl,-x ld wh,-z adc wl,wh st z,wl next R16 adiw y,8 popt ret c; code QNEGATE ( xq -- -xq ) c( quad-cell negate) popw popz popd R17 popd R16 com tosl com tosh com wl com wh com zl com zh com R16 com R17 inc R16 if_z inc R17 if_z adiw zl,1 if_z inc wl if_z inc wh if_z adiw tosl,1 then then then then then pushd R16 pushd R17 pushz pushw ret c; code QABS ( q -- |q| ) c( absolute value quad) tst tosh if_mi goto qnegate then ret c; : Q- ( q1 q2 -- q3 ) QNEGATE Q+ ; c( quad-cell subtract) : DLSHIFT ( d len -- d ) c( double left shift by len ) begin dup while 1- -rot d2* rot repeat drop ; : DRSHIFT ( d len -- d ) c( double right shift by len ) begin dup while 1- -rot ud2/ rot repeat drop ; code #10 ( len -- n ) c( 10 ^ len 0 if exit then 1 0 rot dup if 0 ?do 10 ud* loop else drop then ; \ : C># ( len -- n ) c( converts ASCII digits string in InPad to binary ) \ 0 swap begin dup inptr @ swap + 1- C@ 30 - \ over 1- #10 UM* drop under+ 1- dup 0= until drop ; \ RZ6AT ========================================================================